home *** CD-ROM | disk | FTP | other *** search
/ Giga Games 1 / Giga Games.iso / net / usenet / volume2 / dungeon / part06 < prev    next >
Encoding:
Internet Message Format  |  1987-09-02  |  55.7 KB
  1. Path: uunet!seismo!ut-sally!im4u!rutgers!mit-eddie!uw-beaver!tektronix!tekgen!tekred!games-request
  2. From: games-request@tekred.TEK.COM
  3. Newsgroups: comp.sources.games
  4. Subject: v02i039:  dungeon - game of adventure, Part06/14
  5. Message-ID: <1562@tekred.TEK.COM>
  6. Date: 1 Sep 87 20:37:38 GMT
  7. Sender: billr@tekred.TEK.COM
  8. Lines: 2335
  9. Approved: billr@tekred.TEK.COM
  10.  
  11. Submitted by: Bill Randle <games-request@tekred.TEK.COM>
  12. Comp.sources.games: Volume 2, Issue 39
  13. Archive-name: dungeon/Part06
  14.  
  15.     [Due to a messup on my part, the first five parts of the
  16.      distribution will say "Part n of 7" when unshared.  They are
  17.      really "Part n of 14".  Sorry for the inconvenience. -br]
  18.  
  19. #! /bin/sh
  20. # This is a shell archive.  Remove anything before this line, then unpack
  21. # it by saving it into a file and typing "sh file".  To overwrite existing
  22. # files, type "sh file -c".  You can also feed this as standard input via
  23. # unshar, or by typing "sh <file", e.g..  If this archive is complete, you
  24. # will see the following message at the end:
  25. #        "End of archive 6 (of 14)."
  26. # Contents:  History actors.F dgame.F dmain.F dverb1.F np.F np2.F
  27. #   nrooms.F oflags.h speak.F
  28. # Wrapped by billr@tekred on Tue Apr 21 10:24:34 1987
  29. PATH=/bin:/usr/bin:/usr/ucb ; export PATH
  30. if test -f History -a "${1}" != "-c" ; then 
  31.   echo shar: Will not over-write existing file \"History\"
  32. else
  33. echo shar: Extracting \"History\" \(4401 characters\)
  34. sed "s/^X//" >History <<'END_OF_History'
  35. X    History of the Unix f77 Implementation of Dungeon
  36. X    =================================================
  37. X
  38. XThis version of dungeon has been modified from the original source
  39. Xso that it will compile and execute on Unix[TM] Systems using the
  40. Xf77 FORTRAN Compiler.  The original was written in DEC FORTRAN,
  41. Xtranslated from MDL.  See the file "dungeon.doc" for the complete
  42. Xoriginal documentation.  See the file "PDP.doc" for notes on the
  43. XUnix/pdp implementation.
  44. X
  45. XI. From the original documentation...
  46. X
  47. XTo:    Dungeon Players
  48. XFrom:    "The Translator"
  49. XSubj:    Game Information
  50. XDate:    8-OCT-80
  51. X
  52. X
  53. XThis is the first (and last) source release of the PDP-11 version of 
  54. XDungeon.
  55. X
  56. XPlease note that Dungeon has been superceded by the game ZORK(tm).
  57. XThe following is an extract from the new product announcement for
  58. XZORK in the September, 1980 issue of the RT-11 SIG newsletter:
  59. X
  60. X  "'ZORK:  The Great Underground Empire - Part I' ...was developed
  61. X   by the original authors based on their ZORK (Dungeon) game for
  62. X   the PDP-10.  It features a greatly improved parser;  command
  63. X   input and transcript output files;  SAVEs to any device and
  64. X   file name;  and adaptation to different terminal types,
  65. X   including a status line on VT100s.  Note:  this is not the
  66. X   FORTRAN version that has been available through DECUS.  This
  67. X   version has been completely rewritten to run efficiently on
  68. X   small machines - up to 10 times as fast as the DECUS version.
  69. X
  70. X   ...ZORK runs under RT-ll, HT-ll, or RSTS/E and requires as
  71. X   little as 20K words of memory and a single floppy disk drive.
  72. X   The game package, consisting of an RX01-format diskette and
  73. X   an instruction booklet, is available from Infocom, Inc.,
  74. X   P.O. Box 120, Kendall Station, Cambridge, Ma. 02142."
  75. X
  76. XZORK(tm) is a trademark of Infocom, Inc.  It is available for several
  77. Xpopular personal computers as well as for the PDP-ll.
  78. X
  79. X
  80. XSUMMARY
  81. X-------
  82. X
  83. X            Welcome to Dungeon!
  84. X
  85. X   Dungeon is a game of adventure, danger, and low cunning.  In it
  86. Xyou will explore some of the most amazing territory ever seen by mortal
  87. Xman.  Hardened adventurers have run screaming from the terrors contained
  88. Xwithin.
  89. X
  90. X   In Dungeon, the intrepid explorer delves into the forgotten secrets
  91. Xof a lost labyrinth deep in the bowels of the earth, searching for
  92. Xvast treasures long hidden from prying eyes, treasures guarded by
  93. Xfearsome monsters and diabolical traps!
  94. X
  95. X   No DECsystem should be without one!
  96. X
  97. X   Dungeon was created at the Programming Technology Division of the MIT
  98. XLaboratory for Computer Science by Tim Anderson, Marc Blank, Bruce
  99. XDaniels, and Dave Lebling.  It was inspired by the Adventure game of
  100. XCrowther and Woods, and the Dungeons and Dragons game of Gygax
  101. Xand Arneson.  The original version was written in MDL (alias MUDDLE).
  102. XThe current version was translated from MDL into FORTRAN IV by
  103. Xa somewhat paranoid DEC engineer who prefers to remain anonymous.
  104. X
  105. X   On-line information may be obtained with the commands HELP and INFO.
  106. X
  107. XII. DEC FORTRAN to f77 Conversion (17-nov-81)
  108. X
  109. XThe conversion from DEC FORTRAN to Unix f77 was done by Randy Dietrich,
  110. XLynn Cochran and Sig Peterson.  Much hacking was done to get it to fit
  111. Xin the limited address space of a PDP-11/44 (split I/D).  See the
  112. Xfile "PDP.doc" for all the gory details.  Suffice it to say that by
  113. Xleaving out the debugging package and not linking in the f77 i/o
  114. Xlibrary they managed to get it to run.
  115. X
  116. XIII. PDP to VAX (dec-85)
  117. X
  118. XBased on the work of Randy, Lynn and Sig, Bill Randle folded in the
  119. Xfull save/restore functions and the game debugging package (gdt) into
  120. Xthe pdp version to create a Vax/Unix version.  This version also uses
  121. Xf77 i/o, thus eliminating the extra speak and listen processes needed
  122. Xon the pdp.
  123. X
  124. XIV. Cleanup I (11-dec-86)
  125. X
  126. XJohn Gilmore (hoptoad!gnu) cleaned up the source files by moving
  127. Xmost of the common declarations into include files and added
  128. Xcomments from the original (FORTRAN or MDL?) source.  His efforts
  129. Xare greatly appreciated.
  130. X
  131. XV. Cleanup II (9-feb-87)
  132. X
  133. XBill Randle (billr@tekred.tek.com) added the pdp dependencies back
  134. Xinto the Vax source files with #ifdefs in order to have just one
  135. Xset of sources.  Previously, there were two sets of source: one for
  136. Xthe pdp and one for the Vax.  In addition, a shell escape of the
  137. Xform !cmd was added and the wizard can enter the gdt without having
  138. Xto recompile the source.  Finally, a man page was generated, based
  139. Xon the dungeon.doc file.
  140. END_OF_History
  141. if test 4401 -ne `wc -c <History`; then
  142.     echo shar: \"History\" unpacked with wrong size!
  143. fi
  144. # end of overwriting check
  145. fi
  146. if test -f actors.F -a "${1}" != "-c" ; then 
  147.   echo shar: Will not over-write existing file \"actors.F\"
  148. else
  149. echo shar: Extracting \"actors.F\" \(6949 characters\)
  150. sed "s/^X//" >actors.F <<'END_OF_actors.F'
  151. XC AAPPLI- APPLICABLES FOR ADVENTURERS
  152. XC
  153. XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
  154. XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  155. XC WRITTEN BY R. M. SUPNIK
  156. XC
  157. XC DECLARATIONS
  158. XC
  159. X    LOGICAL FUNCTION AAPPLI(RI)
  160. X    IMPLICIT INTEGER (A-Z)
  161. X    LOGICAL F,MOVETO
  162. X#include "parser.h"
  163. X#include "gamestate.h"
  164. X#include "rooms.h"
  165. X#include "rflag.h"
  166. X#include "rindex.h"
  167. X#include "xsrch.h"
  168. X#include "objects.h"
  169. X#include "oflags.h"
  170. X#include "oindex.h"
  171. X#include "clock.h"
  172. X#include "advers.h"
  173. X#include "verbs.h"
  174. X#include "flags.h"
  175. XC AAPPLI, PAGE 2
  176. XC
  177. X    IF(RI.EQ.0) GO TO 10
  178. XC                        !IF ZERO, NO APP.
  179. X    AAPPLI=.TRUE.
  180. XC                        !ASSUME WINS.
  181. X    GO TO (1000,2000),RI
  182. XC                        !BRANCH ON ADV.
  183. X    CALL BUG(11,RI)
  184. XC
  185. XC COMMON FALSE RETURN.
  186. XC
  187. X10    AAPPLI=.FALSE.
  188. X    RETURN
  189. XC
  190. XC A1--    ROBOT.  PROCESS MOST COMMANDS GIVEN TO ROBOT.
  191. XC
  192. X1000    IF((PRSA.NE.RAISEW).OR.(PRSO.NE.RCAGE)) GO TO 1200
  193. X    CFLAG(CEVSPH)=.FALSE.
  194. XC                        !ROBOT RAISED CAGE.
  195. X    WINNER=PLAYER
  196. XC                        !RESET FOR PLAYER.
  197. X    F=MOVETO(CAGER,WINNER)
  198. XC                        !MOVE TO NEW ROOM.
  199. X    CALL NEWSTA(CAGE,567,CAGER,0,0)
  200. XC                        !INSTALL CAGE IN ROOM.
  201. X    CALL NEWSTA(ROBOT,0,CAGER,0,0)
  202. XC                        !INSTALL ROBOT IN ROOM.
  203. X    AROOM(AROBOT)=CAGER
  204. XC                        !ALSO MOVE ROBOT/ADV.
  205. X    CAGESF=.TRUE.
  206. XC                        !CAGE SOLVED.
  207. X    OFLAG1(ROBOT)=and(OFLAG1(ROBOT),not(NDSCBT))
  208. X    OFLAG1(SPHER)=or(OFLAG1(SPHER),TAKEBT)
  209. X    RETURN
  210. XC
  211. X1200    IF((PRSA.NE.DRINKW).AND.(PRSA.NE.EATW)) GO TO 1300
  212. X    CALL RSPEAK(568)
  213. XC                        !EAT OR DRINK, JOKE.
  214. X    RETURN
  215. XC
  216. X1300    IF(PRSA.NE.READW) GO TO 1400
  217. XC                        !READ,
  218. X    CALL RSPEAK(569)
  219. XC                        !JOKE.
  220. X    RETURN
  221. XC
  222. X1400    IF((PRSA.EQ.WALKW).OR.(PRSA.EQ.TAKEW).OR.(PRSA.EQ.DROPW)
  223. X&     .OR.(PRSA.EQ.PUTW).OR.(PRSA.EQ.PUSHW).OR.(PRSA.EQ.THROWW)
  224. X&     .OR.(PRSA.EQ.TURNW).OR.(PRSA.EQ.LEAPW)) GO TO 10
  225. X    CALL RSPEAK(570)
  226. XC                        !JOKE.
  227. X    RETURN
  228. XC AAPPLI, PAGE 3
  229. XC
  230. XC A2--    MASTER.  PROCESS MOST COMMANDS GIVEN TO MASTER.
  231. XC
  232. X2000    IF(and(OFLAG2(QDOOR),OPENBT).NE.0) GO TO 2100
  233. X    CALL RSPEAK(783)
  234. XC                        !NO MASTER YET.
  235. X    RETURN
  236. XC
  237. X2100    IF(PRSA.NE.WALKW) GO TO 2200
  238. XC                        !WALK?
  239. X    I=784
  240. XC                        !ASSUME WONT.
  241. X    IF(((HERE.EQ.SCORR).AND.
  242. X&        ((PRSO.EQ.XNORTH).OR.(PRSO.EQ.XENTER))).OR.
  243. X&      ((HERE.EQ.NCORR).AND.
  244. X&        ((PRSO.EQ.XSOUTH).OR.(PRSO.EQ.XENTER))))
  245. X&        I=785
  246. X    CALL RSPEAK(I)
  247. X    RETURN
  248. XC
  249. X2200    IF((PRSA.EQ.TAKEW).OR.(PRSA.EQ.DROPW).OR.(PRSA.EQ.PUTW).OR.
  250. X&      (PRSA.EQ.THROWW).OR.(PRSA.EQ.PUSHW).OR.(PRSA.EQ.TURNW).OR.
  251. X&      (PRSA.EQ.SPINW).OR.(PRSA.EQ.TRNTOW).OR.(PRSA.EQ.FOLLOW).OR.
  252. X&      (PRSA.EQ.STAYW).OR.(PRSA.EQ.OPENW).OR.(PRSA.EQ.CLOSEW).OR.
  253. X&      (PRSA.EQ.KILLW)) GO TO 10
  254. X    CALL RSPEAK(786)
  255. XC                        !MASTER CANT DO IT.
  256. X    RETURN
  257. XC
  258. X    END
  259. XC THIEFD-    INTERMOVE THIEF DEMON
  260. XC
  261. XC DECLARATIONS
  262. XC
  263. X    SUBROUTINE THIEFD
  264. X    IMPLICIT INTEGER (A-Z)
  265. X    LOGICAL ONCE,PROB,QHERE,QSTILL,LIT,WINNIN
  266. X#include "gamestate.h"
  267. XC
  268. X#include "debug.h"
  269. X#include "rooms.h"
  270. X#include "rflag.h"
  271. X#include "rindex.h"
  272. X#include "objects.h"
  273. X#include "oflags.h"
  274. X#include "oindex.h"
  275. X#include "villians.h"
  276. X#include "flags.h"
  277. XC
  278. XC FUNCTIONS AND DATA
  279. XC
  280. X    QSTILL(R)=(QHERE(STILL,R).OR.(OADV(STILL).EQ.-THIEF))
  281. XC THIEFD, PAGE 2
  282. XC
  283. X#ifdef debug
  284. X    DFLAG=and(PRSFLG, 32768).NE.0
  285. X#endif debug
  286. XC                        !SET UP DETAIL FLAG.
  287. X    ONCE=.FALSE.
  288. XC                        !INIT FLAG.
  289. X1025    RHERE=OROOM(THIEF)
  290. XC                        !VISIBLE POS.
  291. X    IF(RHERE.NE.0) THFPOS=RHERE
  292. XC
  293. X    IF(THFPOS.EQ.HERE) GO TO 1100
  294. XC                        !THIEF IN WIN RM?
  295. X    IF(THFPOS.NE.TREAS) GO TO 1400
  296. XC                        !THIEF NOT IN TREAS?
  297. XC
  298. XC THIEF IS IN TREASURE ROOM, AND WINNER IS NOT.
  299. XC
  300. X#ifdef debug
  301. X    IF(DFLAG) PRINT 10
  302. X10    FORMAT(' THIEFD-- IN TREASURE ROOM')
  303. X#endif debug
  304. X    IF(RHERE.EQ.0) GO TO 1050
  305. XC                        !VISIBLE?
  306. X    CALL NEWSTA(THIEF,0,0,0,0)
  307. XC                        !YES, VANISH.
  308. X    RHERE=0
  309. X    IF(QSTILL(TREAS)) CALL NEWSTA(STILL,0,0,THIEF,0)
  310. X1050    I=ROBADV(-THIEF,THFPOS,0,0)
  311. XC                        !DROP VALUABLES.
  312. X    IF(QHERE(EGG,THFPOS)) OFLAG2(EGG)=or(OFLAG2(EGG),OPENBT)
  313. X    GO TO 1700
  314. XC
  315. XC THIEF AND WINNER IN SAME ROOM.
  316. XC
  317. X1100    IF(THFPOS.EQ.TREAS) GO TO 1700
  318. XC                        !IF TREAS ROOM, NOTHING.
  319. X    IF(and(RFLAG(THFPOS),RLIGHT).NE.0) GO TO 1400
  320. X#ifdef debug
  321. X    IF(DFLAG) PRINT 20
  322. X20    FORMAT(' THIEFD-- IN ADV ROOM')
  323. X#endif debug
  324. X    IF(THFFLG) GO TO 1300
  325. XC                        !THIEF ANNOUNCED?
  326. X    IF((RHERE.NE.0).OR.PROB(70,70)) GO TO 1150
  327. XC                        !IF INVIS AND 30%.
  328. X    IF(OCAN(STILL).NE.THIEF) GO TO 1700
  329. XC                        !ABORT IF NO STILLETTO.
  330. X    CALL NEWSTA(THIEF,583,THFPOS,0,0)
  331. XC                        !INSERT THIEF INTO ROOM.
  332. X    THFFLG=.TRUE.
  333. XC                        !THIEF IS ANNOUNCED.
  334. X    RETURN
  335. XC
  336. X1150    IF((RHERE.EQ.0).OR.(and(OFLAG2(THIEF),FITEBT).EQ.0))
  337. X&        GO TO 1200
  338. X    IF(WINNIN(THIEF,WINNER)) GO TO 1175
  339. XC                        !WINNING?
  340. X    CALL NEWSTA(THIEF,584,0,0,0)
  341. XC                        !NO, VANISH THIEF.
  342. X    OFLAG2(THIEF)=and(OFLAG2(THIEF), not(FITEBT))
  343. X    IF(QSTILL(THFPOS)) CALL NEWSTA(STILL,0,0,THIEF,0)
  344. X    RETURN
  345. XC
  346. X1175    IF(PROB(90,90)) GO TO 1700
  347. XC                        !90% CHANCE TO STAY.
  348. XC
  349. X1200    IF((RHERE.EQ.0).OR.PROB(70,70)) GO TO 1250
  350. XC                        !IF VISIBLE AND 30%
  351. X    CALL NEWSTA(THIEF,585,0,0,0)
  352. XC                        !VANISH THIEF.
  353. X    IF(QSTILL(THFPOS)) CALL NEWSTA(STILL,0,0,THIEF,0)
  354. X    RETURN
  355. XC
  356. X1300    IF(RHERE.EQ.0) GO TO 1700
  357. XC                        !ANNOUNCED.  VISIBLE?
  358. X1250    IF(PROB(70,70)) RETURN
  359. XC                        !70% CHANCE TO DO NOTHING.
  360. X    THFFLG=.TRUE.
  361. X    NR=ROBRM(THFPOS,100,0,0,-THIEF)+ROBADV(WINNER,0,0,-THIEF)
  362. X    I=586
  363. XC                        !ROBBED EM.
  364. X    IF(RHERE.NE.0) I=588
  365. XC                        !WAS HE VISIBLE?
  366. X    IF(NR.NE.0) I=I+1
  367. XC                        !DID HE GET ANYTHING?
  368. X    CALL NEWSTA(THIEF,I,0,0,0)
  369. XC                        !VANISH THIEF.
  370. X    IF(QSTILL(THFPOS))
  371. X&        CALL NEWSTA(STILL,0,0,THIEF,0)
  372. X    IF((NR.NE.0).AND..NOT.LIT(THFPOS)) CALL RSPEAK(406)
  373. X    RHERE=0
  374. X    GO TO 1700
  375. XC                        !ONWARD.
  376. XC
  377. XC NOT IN ADVENTURERS ROOM.
  378. XC
  379. X1400    CALL NEWSTA(THIEF,0,0,0,0)
  380. XC                        !VANISH.
  381. X    RHERE=0
  382. X#ifdef debug
  383. X    IF(DFLAG) PRINT 30,THFPOS
  384. X30    FORMAT(' THIEFD-- IN ROOM ',I4)
  385. X#endif debug
  386. X    IF(QSTILL(THFPOS))
  387. X&        CALL NEWSTA(STILL,0,0,THIEF,0)
  388. X    IF(and(RFLAG(THFPOS),RSEEN).EQ.0) GO TO 1700
  389. X    I=ROBRM(THFPOS,75,0,0,-THIEF)
  390. XC                        !ROB ROOM 75%.
  391. X    IF((THFPOS.LT.MAZE1).OR.(THFPOS.GT.MAZ15).OR.
  392. X&        (HERE.LT.MAZE1).OR.(HERE.GT.MAZ15)) GO TO 1500
  393. X    DO 1450 I=1,OLNT
  394. XC                        !BOTH IN MAZE.
  395. X      IF(.NOT.QHERE(I,THFPOS).OR.PROB(60,60).OR.
  396. X&        (and(OFLAG1(I),(VISIBT+TAKEBT)).NE.(VISIBT+TAKEBT)))
  397. X&        GO TO 1450
  398. X      CALL RSPSUB(590,ODESC2(I))
  399. XC                        !TAKE OBJECT.
  400. X      IF(PROB(40,20)) GO TO 1700
  401. X      CALL NEWSTA(I,0,0,0,-THIEF)
  402. XC                        !MOST OF THE TIME.
  403. X      OFLAG2(I)=or(OFLAG2(I),TCHBT)
  404. X      GO TO 1700
  405. X1450    CONTINUE
  406. X    GO TO 1700
  407. XC
  408. X1500    DO 1550 I=1,OLNT
  409. XC                        !NOT IN MAZE.
  410. X      IF(.NOT.QHERE(I,THFPOS).OR.(OTVAL(I).NE.0).OR.PROB(80,60).OR.
  411. X&        (and(OFLAG1(I),(VISIBT+TAKEBT)).NE.(VISIBT+TAKEBT)))
  412. X&        GO TO 1550
  413. X      CALL NEWSTA(I,0,0,0,-THIEF)
  414. X      OFLAG2(I)=or(OFLAG2(I),TCHBT)
  415. X      GO TO 1700
  416. X1550    CONTINUE
  417. XC
  418. XC NOW MOVE TO NEW ROOM.
  419. XC
  420. X1700    IF(OADV(ROPE).EQ.-THIEF) DOMEF=.FALSE.
  421. X    IF(ONCE) GO TO 1800
  422. X    ONCE=.NOT.ONCE
  423. X1750    THFPOS=THFPOS-1
  424. XC                        !NEXT ROOM.
  425. X    IF(THFPOS.LE.0) THFPOS=RLNT
  426. X    IF(and(RFLAG(THFPOS),(RLAND+RSACRD+REND)).NE.RLAND)
  427. X&        GO TO 1750
  428. X    THFFLG=.FALSE.
  429. XC                        !NOT ANNOUNCED.
  430. X    GO TO 1025
  431. XC                        !ONCE MORE.
  432. XC
  433. XC ALL DONE.
  434. XC
  435. X1800    IF(THFPOS.EQ.TREAS) RETURN
  436. XC                        !IN TREASURE ROOM?
  437. X    J=591
  438. XC                        !NO, DROP STUFF.
  439. X    IF(THFPOS.NE.HERE) J=0
  440. X    DO 1850 I=1,OLNT
  441. X      IF((OADV(I).NE.-THIEF).OR.PROB(70,70).OR.
  442. X&        (OTVAL(I).GT.0)) GO TO 1850
  443. X      CALL NEWSTA(I,J,THFPOS,0,0)
  444. X      J=0
  445. X1850    CONTINUE
  446. X    RETURN
  447. XC
  448. X    END
  449. END_OF_actors.F
  450. if test 6949 -ne `wc -c <actors.F`; then
  451.     echo shar: \"actors.F\" unpacked with wrong size!
  452. fi
  453. # end of overwriting check
  454. fi
  455. if test -f dgame.F -a "${1}" != "-c" ; then 
  456.   echo shar: Will not over-write existing file \"dgame.F\"
  457. else
  458. echo shar: Extracting \"dgame.F\" \(4492 characters\)
  459. sed "s/^X//" >dgame.F <<'END_OF_dgame.F'
  460. XC GAME- MAIN COMMAND LOOP FOR DUNGEON
  461. XC
  462. XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
  463. XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  464. XC WRITTEN BY R. M. SUPNIK
  465. XC
  466. XC DECLARATIONS
  467. XC
  468. X    SUBROUTINE GAME
  469. X    IMPLICIT INTEGER (A-Z)
  470. X    LOGICAL RMDESC,VAPPLI,RAPPLI,AAPPLI
  471. X    LOGICAL F,PARSE,FINDXT,XVEHIC,LIT
  472. X    CHARACTER SECHO(4)
  473. X    CHARACTER GDTSTR(3)
  474. X#include "parser.h"
  475. X#include "gamestate.h"
  476. X#include "state.h"
  477. X#include "io.h"
  478. X#include "rooms.h"
  479. X#include "rindex.h"
  480. X#include "objects.h"
  481. X#include "oflags.h"
  482. X#include "oindex.h"
  483. X#include "advers.h"
  484. X#include "verbs.h"
  485. X#include "flags.h"
  486. XC
  487. XC FUNCTIONS AND DATA
  488. XC
  489. X    DATA SECHO/'E','C','H','O'/
  490. X    DATA GDTSTR/'G','D','T'/
  491. XC GAME, PAGE 2
  492. XC
  493. XC START UP, DESCRIBE CURRENT LOCATION.
  494. XC
  495. X    CALL RSPEAK(1)
  496. XC                        !WELCOME ABOARD.
  497. X    F=RMDESC(3)
  498. XC                        !START GAME.
  499. XC
  500. XC NOW LOOP, READING AND EXECUTING COMMANDS.
  501. XC
  502. X100    WINNER=PLAYER
  503. XC                        !PLAYER MOVING.
  504. X    TELFLG=.FALSE.
  505. XC                        !ASSUME NOTHING TOLD.
  506. X    IF(PRSCON.LE.1) CALL RDLINE(INBUF,INLNT,1)
  507. XC
  508. X    DO 150 I=1,3
  509. XC                        !CALL ON GDT?
  510. X      IF(INBUF(I+PRSCON-1).NE.GDTSTR(I)) GO TO 200
  511. X150    CONTINUE
  512. X    CALL GDT
  513. XC                        !YES, INVOKE.
  514. X    GO TO 100
  515. XC                        !ONWARD.
  516. XC
  517. X200    MOVES=MOVES+1
  518. X    PRSWON=PARSE(INBUF,INLNT,.TRUE.)
  519. X    IF(.NOT.PRSWON) GO TO 400
  520. XC                        !PARSE LOSES?
  521. X    IF(XVEHIC(1)) GO TO 400
  522. XC                        !VEHICLE HANDLE?
  523. XC
  524. X    IF(PRSA.EQ.TELLW) GO TO 2000
  525. XC                        !TELL?
  526. X300    IF((PRSO.EQ.VALUA).OR.(PRSO.EQ.EVERY)) GO TO 900
  527. X    IF(.NOT.VAPPLI(PRSA)) GO TO 400
  528. XC                        !VERB OK?
  529. X350    IF(.NOT.ECHOF.AND.(HERE.EQ.ECHOR)) GO TO 1000
  530. X    F=RAPPLI(RACTIO(HERE))
  531. XC
  532. X400    CALL XENDMV(TELFLG)
  533. XC                        !DO END OF MOVE.
  534. X    IF(.NOT.LIT(HERE)) PRSCON=1
  535. X    GO TO 100
  536. XC
  537. X900    CALL VALUAC(VALUA)
  538. X    GO TO 350
  539. XC GAME, PAGE 3
  540. XC
  541. XC SPECIAL CASE-- ECHO ROOM.
  542. XC IF INPUT IS NOT 'ECHO' OR A DIRECTION, JUST ECHO.
  543. XC
  544. X1000    CALL RDLINE(INBUF,INLNT,0)
  545. X    MOVES=MOVES+1
  546. XC                        !CHARGE FOR MOVES.
  547. X    DO 1100 I=1,4
  548. XC                        !INPUT = ECHO?
  549. X      IF(INBUF(I).NE.SECHO(I)) GO TO 1300
  550. X1100    CONTINUE
  551. XC
  552. XC   Note: the following DO loop was changed from DO 1200 I=5,78
  553. XC     The change was necessary because the RDLINE function was changed,
  554. XC      and no longer provides a 78 character buffer padded with blanks.
  555. XC
  556. X    DO 1200 I=5,INLNT
  557. X      IF(INBUF(I).NE.' ') GO TO 1300
  558. X1200    CONTINUE
  559. XC
  560. X    CALL RSPEAK(571)
  561. XC                        !KILL THE ECHO.
  562. X    ECHOF=.TRUE.
  563. X    OFLAG2(BAR)=and(OFLAG2(BAR), not(SCRDBT))
  564. X    PRSWON=.TRUE.
  565. XC                        !FAKE OUT PARSER.
  566. X    PRSCON=1
  567. XC                        !FORCE NEW INPUT.
  568. X    GO TO 400
  569. XC
  570. X1300    PRSWON=PARSE(INBUF,INLNT,.FALSE.)
  571. X    IF(.NOT.PRSWON .OR. (PRSA.NE.WALKW))
  572. X&        GO TO 1400
  573. X    IF(FINDXT(PRSO,HERE)) GO TO 300
  574. XC                        !VALID EXIT?
  575. XC
  576. X#ifdef PDP
  577. X1400    call outstr(INLINE, INLNT)
  578. X#else
  579. X1400    WRITE(OUTCH,1410) (INBUF(J),J=1,INLNT)
  580. X1410    FORMAT(1X,78A1)
  581. X#endif PDP
  582. X    TELFLG=.TRUE.
  583. XC                        !INDICATE OUTPUT.
  584. X    GO TO 1000
  585. XC                        !MORE ECHO ROOM.
  586. XC GAME, PAGE 4
  587. XC
  588. XC SPECIAL CASE-- TELL <ACTOR>, NEW COMMAND
  589. XC NOTE THAT WE CANNOT BE IN THE ECHO ROOM.
  590. XC
  591. X2000    IF(and(OFLAG2(PRSO),ACTRBT).NE.0) GO TO 2100
  592. X    CALL RSPEAK(602)
  593. XC                        !CANT DO IT.
  594. X    GO TO 350
  595. XC                        !VAPPLI SUCCEEDS.
  596. XC
  597. X2100    WINNER=OACTOR(PRSO)
  598. XC                        !NEW PLAYER.
  599. X    HERE=AROOM(WINNER)
  600. XC                        !NEW LOCATION.
  601. X    IF(PRSCON.LE.1) GO TO 2700
  602. XC                        !ANY INPUT?
  603. X    IF(PARSE(INBUF,INLNT,.TRUE.)) GO TO 2150
  604. X2700    I=341
  605. XC                        !FAILS.
  606. X    IF(TELFLG) I=604
  607. XC                        !GIVE RESPONSE.
  608. X    CALL RSPEAK(I)
  609. X2600    WINNER=PLAYER
  610. XC                        !RESTORE STATE.
  611. X    HERE=AROOM(WINNER)
  612. X    GO TO 350
  613. XC
  614. X2150    IF(AAPPLI(AACTIO(WINNER))) GO TO 2400
  615. XC                        !ACTOR HANDLE?
  616. X    IF(XVEHIC(1)) GO TO 2400
  617. XC                        !VEHICLE HANDLE?
  618. X    IF((PRSO.EQ.VALUA).OR.(PRSO.EQ.EVERY)) GO TO 2900
  619. X    IF(.NOT.VAPPLI(PRSA)) GO TO 2400
  620. XC                        !VERB HANDLE?
  621. X2350    F=RAPPLI(RACTIO(HERE))
  622. XC
  623. X2400    CALL XENDMV(TELFLG)
  624. XC                        !DO END OF MOVE.
  625. X    GO TO 2600
  626. XC                        !DONE.
  627. XC
  628. X2900    CALL VALUAC(VALUA)
  629. XC                        !ALL OR VALUABLES.
  630. X    GO TO 350
  631. XC
  632. X    END
  633. XC XENDMV-    EXECUTE END OF MOVE FUNCTIONS.
  634. XC
  635. XC DECLARATIONS
  636. XC
  637. X    SUBROUTINE XENDMV(FLAG)
  638. X    IMPLICIT INTEGER(A-Z)
  639. X    LOGICAL F,CLOCKD,FLAG,XVEHIC
  640. X#include "parser.h"
  641. X#include "villians.h"
  642. XC
  643. X    IF(.NOT.FLAG) CALL RSPEAK(341)
  644. XC                        !DEFAULT REMARK.
  645. X    IF(THFACT) CALL THIEFD
  646. XC                        !THIEF DEMON.
  647. X    IF(PRSWON) CALL FIGHTD
  648. XC                        !FIGHT DEMON.
  649. X    IF(SWDACT) CALL SWORDD
  650. XC                        !SWORD DEMON.
  651. X    IF(PRSWON) F=CLOCKD(X)
  652. XC                        !CLOCK DEMON.
  653. X    IF(PRSWON) F=XVEHIC(2)
  654. XC                        !VEHICLE READOUT.
  655. X    RETURN
  656. X    END
  657. XC XVEHIC- EXECUTE VEHICLE FUNCTION
  658. XC
  659. XC DECLARATIONS
  660. XC
  661. X    LOGICAL FUNCTION XVEHIC(N)
  662. X    IMPLICIT INTEGER(A-Z)
  663. X    LOGICAL OAPPLI
  664. X#include "gamestate.h"
  665. X#include "objects.h"
  666. X#include "advers.h"
  667. XC
  668. X    XVEHIC=.FALSE.
  669. XC                        !ASSUME LOSES.
  670. X    AV=AVEHIC(WINNER)
  671. XC                        !GET VEHICLE.
  672. X    IF(AV.NE.0) XVEHIC=OAPPLI(OACTIO(AV),N)
  673. X    RETURN
  674. X    END
  675. END_OF_dgame.F
  676. if test 4492 -ne `wc -c <dgame.F`; then
  677.     echo shar: \"dgame.F\" unpacked with wrong size!
  678. fi
  679. # end of overwriting check
  680. fi
  681. if test -f dmain.F -a "${1}" != "-c" ; then 
  682.   echo shar: Will not over-write existing file \"dmain.F\"
  683. else
  684. echo shar: Extracting \"dmain.F\" \(6633 characters\)
  685. sed "s/^X//" >dmain.F <<'END_OF_dmain.F'
  686. XC DUNGEON-- MAIN PROGRAM
  687. XC
  688. XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
  689. XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  690. XC WRITTEN BY R. M. SUPNIK
  691. XC
  692. X    PROGRAM DUNGEO
  693. XC
  694. XC DECLARATIONS
  695. XC
  696. X    IMPLICIT INTEGER (A-Z)
  697. X    LOGICAL INIT
  698. X#include "parser.h"
  699. X#include "gamestate.h"
  700. X#include "state.h"
  701. X#include "screen.h"
  702. X#include "puzzle.h"
  703. XC
  704. XC MISCELLANEOUS VARIABLES
  705. XC
  706. X    CHARACTER VEDIT
  707. X    COMMON /STAR/ MBASE,STRBIT
  708. X    COMMON /VERS/ VMAJ,VMIN,VEDIT
  709. X    COMMON /BATS/ BATDRP(9)
  710. X#include "io.h"
  711. X#include "debug.h"
  712. X    COMMON /HYPER/ HFACTR
  713. X#include "rooms.h"
  714. X#include "rflag.h"
  715. X#include "rindex.h"
  716. X#include "exits.h"
  717. X#include "curxt.h"
  718. X#include "xpars.h"
  719. X#include "xsrch.h"
  720. X#include "objects.h"
  721. X#include "oflags.h"
  722. X#include "oindex.h"
  723. X#include "clock.h"
  724. X
  725. X#include "villians.h"
  726. X#include "advers.h"
  727. X#include "verbs.h"
  728. X#include "flags.h"
  729. XC DUNGEON, PAGE 2
  730. XC
  731. XC DATA STATEMENTS FOR CONSTANT ARRAYS
  732. XC
  733. X    DATA VMAJ/2/,VMIN/6/,VEDIT/'A'/
  734. XC
  735. X    DATA SDIR/o'40000'/,SIND/o'20000'/,SSTD/o'10000'/,
  736. X&        SFLIP/o'4000'/,SDRIV/o'2000'/,SVMASK/o'777'/
  737. X    DATA VABIT/o'40000'/,VRBIT/o'20000'/,VTBIT/o'10000'/,
  738. X&        VCBIT/o'4000'/,VEBIT/o'2000'/,VFBIT/o'1000'/,
  739. X&        VPMASK/o'777'/
  740. XC
  741. X    DATA BATDRP/66,67,68,69,70,71,72,65,73/
  742. XC
  743. X    DATA SCOLDR/o'2000',153,o'12000',154,o'6000',152,o'16000',151/
  744. X    DATA SCOLWL/151,207,o'6000',152,208,o'16000',
  745. X&        153,206,o'12000',154,205,o'2000'/
  746. XC
  747. X    DATA HFACTR/500/
  748. XC
  749. X    DATA CPDR/o'2000',-8,o'4000',-7,o'6000',1,o'10000',9,
  750. X&        o'12000',8,o'14000',7,o'16000',-1,o'20000',-9/
  751. X    DATA CPWL/205,-8,206,8,207,1,208,-1/
  752. X    DATA CPVEC/1,1,1,1,1,1,1,1,
  753. X&        1,0,-1,0,0,-1,0,1,
  754. X&        1,-1,0,1,0,-2,0,1,
  755. X&        1,0,0,0,0,1,0,1,
  756. X&        1,-3,0,0,-1,-1,0,1,
  757. X&        1,0,0,-1,0,0,0,1,
  758. X&        1,1,1,0,0,0,1,1,
  759. X&        1,1,1,1,1,1,1,1/
  760. XC
  761. X    DATA CEVCUR/1/,CEVMNT/2/,CEVLNT/3/,CEVMAT/4/,
  762. X&        CEVCND/5/,CEVBAL/6/,CEVBRN/7/,CEVFUS/8/,
  763. X&        CEVLED/9/,CEVSAF/10/,CEVVLG/11/,CEVGNO/12/,
  764. X&        CEVBUC/13/,CEVSPH/14/,CEVEGH/15/,
  765. X&        CEVFOR/16/,CEVSCL/17/,CEVZGI/18/,CEVZGO/19/,
  766. X&        CEVSTE/20/,CEVMRS/21/,CEVPIN/22/,CEVINQ/23/,
  767. X&        CEVFOL/24/
  768. XC
  769. X    DATA XRMASK/o'377'/,XDMASK/o'76000'/,XFMASK/3/
  770. X    DATA XFSHFT/256/,XASHFT/256/
  771. X    DATA XNORM/1/,XNO/2/,XCOND/3/,XDOOR/4/
  772. X    DATA XELNT/1,2,3,3/,XLFLAG/o'100000'/
  773. X    DATA XMIN/o'2000'/,XMAX/o'40000'/,XUP/o'22000'/,XDOWN/o'24000'/
  774. X    DATA XNORTH/o'2000'/,XSOUTH/o'12000'/,XENTER/o'32000'/,
  775. X&               XEXIT/o'34000'/
  776. X    DATA XEAST/o'6000'/,XWEST/o'16000'/
  777. XC
  778. X    DATA PLAYER/1/,AROBOT/2/,AMASTR/3/
  779. X    DATA ASTAG/o'100000'/
  780. XC
  781. X    DATA RSEEN/o'100000'/,RLIGHT/o'40000'/,RLAND/o'20000'/
  782. X    DATA RWATER/o'10000'/,RAIR/o'4000'/,RSACRD/o'2000'/,
  783. X&        RFILL/o'1000'/
  784. X    DATA RMUNG/o'400'/,RBUCK/o'200'/,RHOUSE/o'100'/,
  785. X&        RNWALL/o'40'/,REND/o'20'/
  786. XC
  787. X    DATA WHOUS/2/,LROOM/8/,CELLA/9/
  788. X    DATA MTROL/10/,MAZE1/11/
  789. X    DATA MGRAT/25/,MAZ15/30/
  790. X    DATA FORE1/31/,FORE3/33/,CLEAR/36/,RESER/40/
  791. X    DATA STREA/42/,EGYPT/44/,ECHOR/49/
  792. X    DATA TSHAF/61/
  793. X    DATA BSHAF/76/,MMACH/77/,DOME/79/,MTORC/80/
  794. X    DATA CAROU/83/
  795. X    DATA RIDDL/91/,LLD2/94/,TEMP1/96/,TEMP2/97/,MAINT/100/
  796. X    DATA MCYCL/101/,BLROO/102/,TREAS/103/,RIVR1/107/,RIVR2/108/
  797. X    DATA     RIVR3/109/
  798. X    DATA RIVR4/112/,RIVR5/113/,FCHMP/114/,MBARR/119/,FALLS/120/
  799. X    DATA MRAIN/121/,POG/122/,VLBOT/126/,VAIR1/127/,VAIR2/128/
  800. X    DATA     VAIR3/129/,VAIR4/130/
  801. X    DATA LEDG2/131/,LEDG3/132/,LEDG4/133/,MSAFE/135/,CAGER/140/
  802. X    DATA CAGED/141/,TWELL/142/,BWELL/143/,ALICE/144/,ALISM/145/
  803. X    DATA     ALITR/146/,MTREE/147/,BKENT/148/
  804. X    DATA BKVW/151/,BKTWI/153/,BKVAU/154/,BKBOX/155/
  805. X    DATA    CRYPT/157/,TSTRS/158/,MRANT/159/
  806. X    DATA MREYE/160/,MRA/161/,MRB/162/,MRC/163/,MRG/164/
  807. X    DATA    MRD/165/,FDOOR/166/,MRAE/167/
  808. X    DATA MRCE/171/,MRCW/172/,MRGE/173/,MRGW/174/,MRDW/176/
  809. X    DATA    INMIR/177/,SCORR/179/
  810. X    DATA NCORR/182/,PARAP/183/,CELL/184/,PCELL/185/,NCELL/186/
  811. X    DATA    CPANT/188/,CPOUT/189/
  812. X    DATA CPUZZ/190/
  813. XC
  814. X    DATA CINTW/1/,DEADXW/2/,FRSTQW/3/,INXW/4/
  815. X    DATA OUTXW/5/,WALKIW/6/,FIGHTW/7/,FOOW/8/
  816. XC
  817. X    DATA READW/100/,MELTW/101/
  818. X    DATA INFLAW/102/,DEFLAW/103/,ALARMW/104/,EXORCW/105/
  819. X    DATA PLUGW/106/,KICKW/107/,WAVEW/108/,RAISEW/109/,LOWERW/110/
  820. X    DATA RUBW/111/,PUSHW/112/,UNTIEW/113/,TIEW/114/,TIEUPW/115/
  821. X    DATA TURNW/116/,BREATW/117/,KNOCKW/118/,LOOKW/119/
  822. X    DATA EXAMIW/120/,SHAKEW/121/,MOVEW/122/,TRNONW/123/,TRNOFW/124/
  823. X    DATA OPENW/125/,CLOSEW/126/,FINDW/127/,WAITW/128/,SPINW/129/
  824. X    DATA BOARDW/130/,UNBOAW/131/,TAKEW/132/,INVENW/133/
  825. X    DATA FILLW/134/,EATW/135/,DRINKW/136/,BURNW/137/
  826. X    DATA MUNGW/138/,KILLW/139/,ATTACW/141/
  827. X    DATA SWINGW/140/,WALKW/142/,TELLW/143/,PUTW/144/
  828. X    DATA DROPW/145/,GIVEW/146/,POURW/147/,THROWW/148/
  829. XC
  830. X    DATA DIGW/89/,LEAPW/91/,STAYW/73/,FOLLOW/85/
  831. X    DATA HELLOW/151/,LOOKIW/152/,LOOKUW/153/,PUMPW/154/
  832. X    DATA WINDW/155/,CLMBW/156/,CLMBUW/157/,CLMBDW/158/,TRNTOW/159/
  833. XC
  834. X    DATA VISIBT/o'100000'/,READBT/o'40000'/,TAKEBT/o'20000'/,
  835. X&        DOORBT/o'10000'/,TRANBT/o'4000'/,FOODBT/o'2000'/,
  836. X&        NDSCBT/o'1000'/,DRNKBT/o'400'/, CONTBT/o'200'/,
  837. X&        LITEBT/o'100'/,VICTBT/o'40'/,BURNBT/o'20'/,
  838. X&        FLAMBT/o'10'/,TOOLBT/o'4'/,TURNBT/o'2'/,ONBT/o'1'/
  839. XC
  840. X    DATA FINDBT/o'100000'/,SLEPBT/o'40000'/,SCRDBT/o'20000'/,
  841. X&        TIEBT/o'10000'/, CLMBBT/o'4000'/,ACTRBT/o'2000'/,
  842. X&        WEAPBT/o'1000'/,FITEBT/o'400'/, VILLBT/o'200'/,
  843. X&        STAGBT/o'100'/,TRYBT/o'40'/,NOCHBT/o'20'/,
  844. X&        OPENBT/o'10'/,TCHBT/o'4'/,VEHBT/o'2'/,SCHBT/o'1'/
  845. XC
  846. X    DATA GARLI/2/,FOOD/3/,GUNK/4/,COAL/5/,MACHI/7/,DIAMO/8/
  847. X    DATA    TCASE/9/,BOTTL/10/
  848. X    DATA WATER/11/,ROPE/12/,KNIFE/13/,SWORD/14/,LAMP/15/,BLAMP/16/
  849. X    DATA    RUG/17/,LEAVE/18/,TROLL/19/,AXE/20/
  850. X    DATA RKNIF/21/,KEYS/23/,BAR/26/,ICE/30/
  851. X    DATA COFFI/33/,TORCH/34/,TBASK/35/,FBASK/36/,IRBOX/39/
  852. X    DATA GHOST/42/,TRUNK/45/,BELL/46/,BOOK/47/,CANDL/48/
  853. X    DATA MATCH/51/,TUBE/54/,PUTTY/55/,WRENC/56/,SCREW/57/
  854. X    DATA    CYCLO/58/,CHALI/59/
  855. X    DATA THIEF/61/,STILL/62/,WINDO/63/,GRATE/65/,DOOR/66/
  856. X    DATA HPOLE/71/,RBUTT/79/,LEAK/78/,RAILI/75/
  857. X    DATA POT/85/,STATU/86/,IBOAT/87/,DBOAT/88/,PUMP/89/,RBOAT/90/
  858. X    DATA STICK/92/,BUOY/94/,SHOVE/96/,GUANO/97/,BALLO/98/,RECEP/99/
  859. X    DATA BROPE/101/,HOOK1/102/,HOOK2/103/,SAFE/105/,SSLOT/107/
  860. X    DATA    BRICK/109/,FUSE/110/
  861. X    DATA GNOME/111/,BLABE/112/,DBALL/113/,TOMB/119/
  862. X    DATA LCASE/123/,CAGE/124/,RCAGE/125/,SPHER/126/,SQBUT/127/
  863. X    DATA FLASK/132/,POOL/133/,SAFFR/134/,BUCKE/137/,ORICE/139/
  864. X    DATA    ECAKE/138/,RDICE/140/
  865. X    DATA BLICE/141/,ROBOT/142/,FTREE/145/,BILLS/148/,PORTR/149/
  866. X    DATA SCOL/151/,ZGNOM/152/,EGG/154/,BEGG/155/,BAUBL/156/
  867. X    DATA    CANAR/157/,BCANA/158/,YLWAL/159/
  868. X    DATA RDWAL/161/,PINDR/164/
  869. X    DATA RBEAM/171/,ODOOR/172/,QDOOR/173/,CDOOR/175/
  870. X    DATA    NUM1/178/
  871. X    DATA NUM8/185/,WARNI/186/,CSLIT/187/,GCARD/188/,STLDR/189/
  872. X    DATA ITOBJ/192/,OPLAY/193/,EVERY/194/
  873. X    DATA    VALUA/195/,SAILO/196/,TEETH/197/,WALL/198/
  874. X    DATA HANDS/200/,LUNGS/201/,AVIAT/202/
  875. X    DATA WNORT/205/,GWATE/209/,MASTER/215/
  876. XC DUNGEON, PAGE 3
  877. XC
  878. XC 1) INITIALIZE DATA STRUCTURES
  879. XC 2) PLAY GAME
  880. XC
  881. X    IF(INIT(X)) CALL GAME
  882. XC                        !IF INIT, PLAY GAME.
  883. X    CALL EXIT
  884. XC                        !DONE
  885. X    END
  886. END_OF_dmain.F
  887. if test 6633 -ne `wc -c <dmain.F`; then
  888.     echo shar: \"dmain.F\" unpacked with wrong size!
  889. fi
  890. # end of overwriting check
  891. fi
  892. if test -f dverb1.F -a "${1}" != "-c" ; then 
  893.   echo shar: Will not over-write existing file \"dverb1.F\"
  894. else
  895. echo shar: Extracting \"dverb1.F\" \(6815 characters\)
  896. sed "s/^X//" >dverb1.F <<'END_OF_dverb1.F'
  897. XC TAKE-- BASIC TAKE SEQUENCE
  898. XC
  899. XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
  900. XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  901. XC WRITTEN BY R. M. SUPNIK
  902. XC
  903. XC TAKE AN OBJECT (FOR VERBS TAKE, PUT, DROP, READ, ETC.)
  904. XC
  905. X    LOGICAL FUNCTION TAKE(FLG)
  906. XC
  907. XC DECLARATIONS
  908. XC
  909. X    IMPLICIT INTEGER (A-Z)
  910. X    LOGICAL FLG,OBJACT,OAPPLI,QOPEN,QHERE
  911. X#include "parser.h"
  912. X#include "gamestate.h"
  913. X#include "state.h"
  914. X    COMMON /STAR/ MBASE,STRBIT
  915. X#include "objects.h"
  916. X#include "oflags.h"
  917. XC
  918. X#include "advers.h"
  919. XC
  920. XC FUNCTIONS AND DATA
  921. XC
  922. X    QOPEN(O)=(and(OFLAG2(O),OPENBT).NE.0)
  923. XC TAKE, PAGE 2
  924. XC
  925. X    TAKE=.FALSE.
  926. XC                        !ASSUME LOSES.
  927. X    OA=OACTIO(PRSO)
  928. XC                        !GET OBJECT ACTION.
  929. X    IF(PRSO.LE.STRBIT) GO TO 100
  930. XC                        !STAR?
  931. X    TAKE=OBJACT(X)
  932. XC                        !YES, LET IT HANDLE.
  933. X    RETURN
  934. XC
  935. X100    X=OCAN(PRSO)
  936. XC                        !INSIDE?
  937. X    IF(PRSO.NE.AVEHIC(WINNER)) GO TO 400
  938. XC                        !HIS VEHICLE?
  939. X    CALL RSPEAK(672)
  940. XC                        !DUMMY.
  941. X    RETURN
  942. XC
  943. X400    IF(and(OFLAG1(PRSO),TAKEBT).NE.0) GO TO 500
  944. X    IF(.NOT.OAPPLI(OA,0)) CALL RSPEAK(552+RND(5))
  945. X    RETURN
  946. XC
  947. XC OBJECT IS TAKEABLE AND IN POSITION TO BE TAKEN.
  948. XC
  949. X500    IF((X.NE.0).OR. QHERE(PRSO,HERE)) GO TO 600
  950. X    IF(OADV(PRSO).EQ.WINNER) CALL RSPEAK(557)
  951. XC                        !ALREADY GOT IT?
  952. X    RETURN
  953. XC
  954. X600    IF(((X.NE.0).AND.(OADV(X).EQ.WINNER)).OR.
  955. X&        ((WEIGHT(0,PRSO,WINNER)+OSIZE(PRSO)).LE.MXLOAD))
  956. X&        GO TO 700
  957. X    CALL RSPEAK(558)
  958. XC                        !TOO MUCH WEIGHT.
  959. X    RETURN
  960. XC
  961. X700    TAKE=.TRUE.
  962. XC                        !AT LAST.
  963. X    IF(OAPPLI(OA,0)) RETURN
  964. XC                        !DID IT HANDLE?
  965. X    CALL NEWSTA(PRSO,0,0,0,WINNER)
  966. XC                        !TAKE OBJECT FOR WINNER.
  967. X    OFLAG2(PRSO)=or(OFLAG2(PRSO),TCHBT)
  968. X    CALL SCRUPD(OFVAL(PRSO))
  969. XC                        !UPDATE SCORE.
  970. X    OFVAL(PRSO)=0
  971. XC                        !CANT BE SCORED AGAIN.
  972. X    IF(FLG) CALL RSPEAK(559)
  973. XC                        !TELL TAKEN.
  974. X    RETURN
  975. XC
  976. X    END
  977. XC DROP- DROP VERB PROCESSOR
  978. XC
  979. XC DECLARATIONS
  980. XC
  981. X    LOGICAL FUNCTION DROP(Z)
  982. X    IMPLICIT INTEGER (A-Z)
  983. X    LOGICAL F,PUT,OBJACT
  984. X#include "parser.h"
  985. X#include "gamestate.h"
  986. XC
  987. XC ROOMS
  988. X#include "rindex.h"
  989. X#include "objects.h"
  990. X#include "oflags.h"
  991. XC
  992. X#include "advers.h"
  993. X#include "verbs.h"
  994. XC DROP, PAGE 2
  995. XC
  996. X    DROP=.TRUE.
  997. XC                        !ASSUME WINS.
  998. X    X=OCAN(PRSO)
  999. XC                        !GET CONTAINER.
  1000. X    IF(X.EQ.0) GO TO 200
  1001. XC                        !IS IT INSIDE?
  1002. X    IF(OADV(X).NE.WINNER) GO TO 1000
  1003. XC                        !IS HE CARRYING CON?
  1004. X    IF(and(OFLAG2(X),OPENBT).NE.0) GO TO 300
  1005. X    CALL RSPSUB(525,ODESC2(X))
  1006. XC                        !CANT REACH.
  1007. X    RETURN
  1008. XC
  1009. X200    IF(OADV(PRSO).NE.WINNER) GO TO 1000
  1010. XC                        !IS HE CARRYING OBJ?
  1011. X300    IF(AVEHIC(WINNER).EQ.0) GO TO 400
  1012. XC                        !IS HE IN VEHICLE?
  1013. X    PRSI=AVEHIC(WINNER)
  1014. XC                        !YES,
  1015. X    F=PUT(.TRUE.)
  1016. XC                        !DROP INTO VEHICLE.
  1017. X    PRSI=0
  1018. XC                        !DISARM PARSER.
  1019. X    RETURN
  1020. XC                        !DONE.
  1021. XC
  1022. X400    CALL NEWSTA(PRSO,0,HERE,0,0)
  1023. XC                        !DROP INTO ROOM.
  1024. X    IF(HERE.EQ.MTREE) CALL NEWSTA(PRSO,0,FORE3,0,0)
  1025. X    CALL SCRUPD(OFVAL(PRSO))
  1026. XC                        !SCORE OBJECT.
  1027. X    OFVAL(PRSO)=0
  1028. XC                        !CANT BE SCORED AGAIN.
  1029. X    OFLAG2(PRSO)=or(OFLAG2(PRSO),TCHBT)
  1030. XC
  1031. X    IF(OBJACT(X)) RETURN
  1032. XC                        !DID IT HANDLE?
  1033. X    I=0
  1034. XC                        !ASSUME NOTHING TO SAY.
  1035. X    IF(PRSA.EQ.DROPW) I=528
  1036. X    IF(PRSA.EQ.THROWW) I=529
  1037. X    IF((I.NE.0).AND.(HERE.EQ.MTREE)) I=659
  1038. X    CALL RSPSUB(I,ODESC2(PRSO))
  1039. X    RETURN
  1040. XC
  1041. X1000    CALL RSPEAK(527)
  1042. XC                        !DONT HAVE IT.
  1043. X    RETURN
  1044. XC
  1045. X    END
  1046. XC PUT- PUT VERB PROCESSOR
  1047. XC
  1048. XC DECLARATIONS
  1049. XC
  1050. X    LOGICAL FUNCTION PUT(FLG)
  1051. X    IMPLICIT INTEGER (A-Z)
  1052. X    LOGICAL TAKE,QOPEN,QHERE,OBJACT,FLG
  1053. X#include "parser.h"
  1054. X#include "gamestate.h"
  1055. XC
  1056. XC MISCELLANEOUS VARIABLES
  1057. XC
  1058. X    COMMON /STAR/ MBASE,STRBIT
  1059. X#include "objects.h"
  1060. X#include "oflags.h"
  1061. X#include "advers.h"
  1062. X#include "verbs.h"
  1063. XC
  1064. XC FUNCTIONS AND DATA
  1065. XC
  1066. X    QOPEN(R)=((and(OFLAG2(R),OPENBT)).NE.0)
  1067. XC PUT, PAGE 2
  1068. XC
  1069. X    PUT=.FALSE.
  1070. X    IF((PRSO.LE.STRBIT).AND.(PRSI.LE.STRBIT)) GO TO 200
  1071. X    IF(.NOT.OBJACT(X)) CALL RSPEAK(560)
  1072. XC                        !STAR
  1073. X    PUT=.TRUE.
  1074. X    RETURN
  1075. XC
  1076. X200    IF((QOPEN(PRSI))
  1077. X&        .OR.(and(OFLAG1(PRSI),(DOORBT+CONTBT)).NE.0)
  1078. X&        .OR.(and(OFLAG2(PRSI),VEHBT).NE.0)) GO TO 300
  1079. X    CALL RSPEAK(561)
  1080. XC                        !CANT PUT IN THAT.
  1081. X    RETURN
  1082. XC
  1083. X300    IF(QOPEN(PRSI)) GO TO 400
  1084. XC                        !IS IT OPEN?
  1085. X    CALL RSPEAK(562)
  1086. XC                        !NO, JOKE
  1087. X    RETURN
  1088. XC
  1089. X400    IF(PRSO.NE.PRSI) GO TO 500
  1090. XC                        !INTO ITSELF?
  1091. X    CALL RSPEAK(563)
  1092. XC                        !YES, JOKE.
  1093. X    RETURN
  1094. XC
  1095. X500    IF(OCAN(PRSO).NE.PRSI) GO TO 600
  1096. XC                        !ALREADY INSIDE.
  1097. X    CALL RSPSB2(564,ODESC2(PRSO),ODESC2(PRSI))
  1098. X    PUT=.TRUE.
  1099. X    RETURN
  1100. XC
  1101. X600    IF((WEIGHT(0,PRSO,0)+WEIGHT(0,PRSI,0)+OSIZE(PRSO))
  1102. X&        .LE.OCAPAC(PRSI)) GO TO 700
  1103. X    CALL RSPEAK(565)
  1104. XC                        !THEN CANT DO IT.
  1105. X    RETURN
  1106. XC
  1107. XC NOW SEE IF OBJECT (OR ITS CONTAINER) IS IN ROOM
  1108. XC
  1109. X700    J=PRSO
  1110. XC                        !START SEARCH.
  1111. X725    IF(QHERE(J,HERE)) GO TO 750
  1112. XC                        !IS IT HERE?
  1113. X    J=OCAN(J)
  1114. X    IF(J.NE.0) GO TO 725
  1115. XC                        !MORE TO DO?
  1116. X    GO TO 800
  1117. XC                        !NO, SCH FAILS.
  1118. XC
  1119. X750    SVO=PRSO
  1120. XC                        !SAVE PARSER.
  1121. X    SVI=PRSI
  1122. X    PRSA=TAKEW
  1123. X    PRSI=0
  1124. X    IF(.NOT.TAKE(.FALSE.)) RETURN
  1125. XC                        !TAKE OBJECT.
  1126. X    PRSA=PUTW
  1127. X    PRSO=SVO
  1128. X    PRSI=SVI
  1129. X    GO TO 1000
  1130. XC
  1131. XC NOW SEE IF OBJECT IS ON PERSON.
  1132. XC
  1133. X800    IF(OCAN(PRSO).EQ.0) GO TO 1000
  1134. XC                        !INSIDE?
  1135. X    IF(QOPEN(OCAN(PRSO))) GO TO 900
  1136. XC                        !OPEN?
  1137. X    CALL RSPSUB(566,ODESC2(PRSO))
  1138. XC                        !LOSE.
  1139. X    RETURN
  1140. XC
  1141. X900    CALL SCRUPD(OFVAL(PRSO))
  1142. XC                        !SCORE OBJECT.
  1143. X    OFVAL(PRSO)=0
  1144. X    OFLAG2(PRSO)=or(OFLAG2(PRSO),TCHBT)
  1145. X    CALL NEWSTA(PRSO,0,0,0,WINNER)
  1146. XC                        !TEMPORARILY ON WINNER.
  1147. XC
  1148. X1000    IF(OBJACT(X)) RETURN
  1149. XC                        !NO, GIVE OBJECT A SHOT.
  1150. X    CALL NEWSTA(PRSO,2,0,PRSI,0)
  1151. XC                        !CONTAINED INSIDE.
  1152. X    PUT=.TRUE.
  1153. X    RETURN
  1154. XC
  1155. X    END
  1156. XC VALUAC- HANDLES VALUABLES/EVERYTHING
  1157. XC
  1158. XC DECLARATIONS
  1159. XC
  1160. X    SUBROUTINE VALUAC(V)
  1161. X    IMPLICIT INTEGER (A-Z)
  1162. X    LOGICAL LIT,F,F1,TAKE,PUT,DROP,NOTVAL,QHERE
  1163. X#include "parser.h"
  1164. X#include "gamestate.h"
  1165. X#include "objects.h"
  1166. X#include "oflags.h"
  1167. X#include "verbs.h"
  1168. XC
  1169. XC FUNCTIONS AND DATA
  1170. XC
  1171. X    NOTVAL(R)=(SAVEP.EQ.V).AND.(OTVAL(R).LE.0)
  1172. XC VALUAC, PAGE 2
  1173. XC
  1174. X    F=.TRUE.
  1175. XC                        !ASSUME NO ACTIONS.
  1176. X    I=579
  1177. XC                        !ASSUME NOT LIT.
  1178. X    IF(.NOT.LIT(HERE)) GO TO 4000
  1179. XC                        !IF NOT LIT, PUNT.
  1180. X    I=677
  1181. XC                        !ASSUME WRONG VERB.
  1182. X    SAVEP=PRSO
  1183. XC                        !SAVE PRSO.
  1184. X    SAVEH=HERE
  1185. XC                        !SAVE HERE.
  1186. XC
  1187. X100    IF(PRSA.NE.TAKEW) GO TO 1000
  1188. XC                        !TAKE EVERY/VALUA?
  1189. X    DO 500 PRSO=1,OLNT
  1190. XC                        !LOOP THRU OBJECTS.
  1191. X      IF(.NOT.QHERE(PRSO,HERE).OR.
  1192. X&        (and(OFLAG1(PRSO),VISIBT).EQ.0).OR.
  1193. X&        (and(OFLAG2(PRSO),ACTRBT).NE.0).OR.
  1194. X&        NOTVAL(PRSO)) GO TO 500
  1195. X      IF((and(OFLAG1(PRSO),TAKEBT).EQ.0).AND.
  1196. X&        (and(OFLAG2(PRSO),TRYBT).EQ.0)) GO TO 500
  1197. X      F=.FALSE.
  1198. X      CALL RSPSUB(580,ODESC2(PRSO))
  1199. X      F1=TAKE(.TRUE.)
  1200. X      IF(SAVEH.NE.HERE) RETURN
  1201. X500    CONTINUE
  1202. X    GO TO 3000
  1203. XC
  1204. X1000    IF(PRSA.NE.DROPW) GO TO 2000
  1205. XC                        !DROP EVERY/VALUA?
  1206. X    DO 1500 PRSO=1,OLNT
  1207. X      IF((OADV(PRSO).NE.WINNER).OR.NOTVAL(PRSO))
  1208. X&        GO TO 1500
  1209. X      F=.FALSE.
  1210. X      CALL RSPSUB(580,ODESC2(PRSO))
  1211. X      F1=DROP(.TRUE.)
  1212. X      IF(SAVEH.NE.HERE) RETURN
  1213. X1500    CONTINUE
  1214. X    GO TO 3000
  1215. XC
  1216. X2000    IF(PRSA.NE.PUTW) GO TO 3000
  1217. XC                        !PUT EVERY/VALUA?
  1218. X    DO 2500 PRSO=1,OLNT
  1219. XC                        !LOOP THRU OBJECTS.
  1220. X      IF((OADV(PRSO).NE.WINNER)
  1221. X&        .OR.(PRSO.EQ.PRSI).OR.NOTVAL(PRSO).OR.
  1222. X&        (and(OFLAG1(PRSO),VISIBT).EQ.0)) GO TO 2500
  1223. X      F=.FALSE.
  1224. X      CALL RSPSUB(580,ODESC2(PRSO))
  1225. X      F1=PUT(.TRUE.)
  1226. X      IF(SAVEH.NE.HERE) RETURN
  1227. X2500    CONTINUE
  1228. XC
  1229. X3000    I=581
  1230. X    IF(SAVEP.EQ.V) I=582
  1231. XC                        !CHOOSE MESSAGE.
  1232. X4000    IF(F) CALL RSPEAK(I)
  1233. XC                        !IF NOTHING, REPORT.
  1234. X    RETURN
  1235. X    END
  1236. END_OF_dverb1.F
  1237. if test 6815 -ne `wc -c <dverb1.F`; then
  1238.     echo shar: \"dverb1.F\" unpacked with wrong size!
  1239. fi
  1240. # end of overwriting check
  1241. fi
  1242. if test -f np.F -a "${1}" != "-c" ; then 
  1243.   echo shar: Will not over-write existing file \"np.F\"
  1244. else
  1245. echo shar: Extracting \"np.F\" \(4769 characters\)
  1246. sed "s/^X//" >np.F <<'END_OF_np.F'
  1247. XC RDLINE-    READ INPUT LINE
  1248. XC
  1249. XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
  1250. XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  1251. XC WRITTEN BY R. M. SUPNIK
  1252. XC
  1253. XC DECLARATIONS
  1254. XC
  1255. X    SUBROUTINE RDLINE(BUFFER,LENGTH,WHO)
  1256. X    IMPLICIT INTEGER(A-Z)
  1257. X    CHARACTER BUFFER(78)
  1258. X#ifndef PDP
  1259. X    character*78 sysbuf
  1260. X#endif
  1261. X#include "parser.h"
  1262. X#include "io.h"
  1263. X
  1264. X#ifdef PDP
  1265. X5    if (WHO .eq. 1) call prompt
  1266. XC    read a line of input
  1267. X90    call rdlin(BUFFER,LENGTH,WHO)
  1268. X#else
  1269. X5    GO TO (90,10),WHO+1
  1270. XC                        !SEE WHO TO PROMPT FOR.
  1271. X10    WRITE(OUTCH,50)
  1272. XC                        !PROMPT FOR GAME.
  1273. X50    FORMAT(' >',$)
  1274. X
  1275. X90    READ(INPCH,100) BUFFER
  1276. X100    FORMAT(78A1)
  1277. X
  1278. X    DO 200 LENGTH=78,1,-1
  1279. X      IF(BUFFER(LENGTH).NE.' ') GO TO 250
  1280. X200    CONTINUE
  1281. X    GO TO 5
  1282. XC                        !TRY AGAIN.
  1283. X
  1284. XC
  1285. XC    check for shell escape here before things are
  1286. XC    converted to upper case
  1287. XC
  1288. X250    if (buffer(1) .ne. '!') go to 300
  1289. X    do 275 j=2,length
  1290. X      sysbuf(j-1:j-1) = buffer(j)
  1291. X275    continue
  1292. X    sysbuf(j:j) = char(0)
  1293. X    call system(sysbuf)
  1294. X    go to 5
  1295. X
  1296. XC CONVERT TO UPPER CASE
  1297. X300    DO 400 I=1,LENGTH
  1298. X       IF(and((BUFFER(I).GE.'a'),(BUFFER(I).LE.'z')))
  1299. X&        BUFFER(I)=char(ichar(BUFFER(I))-32)
  1300. X400    CONTINUE
  1301. X#endif PDP
  1302. X
  1303. X    if(LENGTH.EQ.0) GO TO 5
  1304. X    PRSCON=1
  1305. XC                        !RESTART LEX SCAN.
  1306. X    RETURN
  1307. X    END
  1308. XC PARSE-    TOP LEVEL PARSE ROUTINE
  1309. XC
  1310. XC DECLARATIONS
  1311. XC
  1312. XC THIS ROUTINE DETAILS ON BIT 0 OF PRSFLG
  1313. XC
  1314. X    LOGICAL FUNCTION PARSE(INBUF,INLNT,VBFLAG)
  1315. X    IMPLICIT INTEGER(A-Z)
  1316. X    CHARACTER INBUF(78)
  1317. X    LOGICAL LEX,SYNMCH,VBFLAG
  1318. X    INTEGER OUTBUF(40)
  1319. X#include "debug.h"
  1320. X#include "parser.h"
  1321. X#include "xsrch.h"
  1322. XC
  1323. X#ifdef debug
  1324. X    DFLAG=and(PRSFLG,1).NE.0
  1325. X#endif
  1326. X    PARSE=.FALSE.
  1327. XC                        !ASSUME FAILS.
  1328. X    PRSA=0
  1329. XC                        !ZERO OUTPUTS.
  1330. X    PRSI=0
  1331. X    PRSO=0
  1332. XC
  1333. X#ifdef PDP
  1334. XC    LEX recoded in C for pdp version (see lex.c)
  1335. X    if(.not. lex(INBUF,INLNT,OUTBUF,OUTLNT,VBFLAG,PRSCON)) goto 100
  1336. X#else
  1337. X    IF(.NOT.LEX(INBUF,INLNT,OUTBUF,OUTLNT,VBFLAG)) GO TO 100
  1338. X#endif
  1339. X    IF(SPARSE(OUTBUF,OUTLNT,VBFLAG)) 100,200,300
  1340. XC                        !DO SYN SCAN.
  1341. XC
  1342. XC PARSE REQUIRES VALIDATION
  1343. XC
  1344. X200    IF(.NOT.VBFLAG) GO TO 350
  1345. XC                        !ECHO MODE, FORCE FAIL.
  1346. X    IF(.NOT.SYNMCH(X)) GO TO 100
  1347. XC                        !DO SYN MATCH.
  1348. X    IF(and((PRSO.GT.0),(PRSO.LT.XMIN))) LASTIT=PRSO
  1349. XC
  1350. XC SUCCESSFUL PARSE OR SUCCESSFUL VALIDATION
  1351. XC
  1352. X300    PARSE=.TRUE.
  1353. X350    CALL ORPHAN(0,0,0,0,0)
  1354. XC                        !CLEAR ORPHANS.
  1355. X#ifdef debug
  1356. X    if(dflag) write(0,*) "parse good"
  1357. X    IF(DFLAG) PRINT 10,PARSE,PRSA,PRSO,PRSI
  1358. X10    FORMAT(' PARSE RESULTS- ',L7,3I7)
  1359. X#endif
  1360. X    RETURN
  1361. XC
  1362. XC PARSE FAILS, DISALLOW CONTINUATION
  1363. XC
  1364. X100    PRSCON=1
  1365. X#ifdef debug
  1366. X    if(dflag) write(0,*) "parse failed"
  1367. X    IF(DFLAG) PRINT 10,PARSE,PRSA,PRSO,PRSI
  1368. X#endif
  1369. X    RETURN
  1370. XC
  1371. X    END
  1372. XC ORPHAN- SET UP NEW ORPHANS
  1373. XC
  1374. XC DECLARATIONS
  1375. XC
  1376. X    SUBROUTINE ORPHAN(O1,O2,O3,O4,O5)
  1377. X    IMPLICIT INTEGER(A-Z)
  1378. X    COMMON /ORPHS/ A,B,C,D,E
  1379. XC
  1380. X    A=O1
  1381. XC                        !SET UP NEW ORPHANS.
  1382. X    B=O2
  1383. X    C=O3
  1384. X    D=O4
  1385. X    E=O5
  1386. X    RETURN
  1387. X    END
  1388. X#ifndef PDP
  1389. XC LEX-    LEXICAL ANALYZER
  1390. XC
  1391. XC
  1392. XC THIS ROUTINE DETAILS ON BIT 1 OF PRSFLAG
  1393. XC
  1394. X    LOGICAL FUNCTION LEX(INBUF,INLNT,OUTBUF,OP,VBFLAG)
  1395. X    IMPLICIT INTEGER(A-Z)
  1396. X    CHARACTER INBUF(78),J,DLIMIT(9)
  1397. X    INTEGER OUTBUF(40)
  1398. X    LOGICAL VBFLAG
  1399. X#include "parser.h"
  1400. XC
  1401. X#include "debug.h"
  1402. XC
  1403. X    DATA DLIMIT/'A','Z',o'100','1','9',o'22','-','-',o'22'/
  1404. XC
  1405. X    DO 100 I=1,40
  1406. XC                        !CLEAR OUTPUT BUF.
  1407. X      OUTBUF(I)=0
  1408. X100    CONTINUE
  1409. XC
  1410. X#ifdef debug
  1411. X    DFLAG=and(PRSFLG,2).NE.0
  1412. X#endif debug
  1413. X    LEX=.FALSE.
  1414. XC                        !ASSUME LEX FAILS.
  1415. X    OP=-1
  1416. XC                        !OUTPUT PTR.
  1417. X50    OP=OP+2
  1418. XC                        !ADV OUTPUT PTR.
  1419. X    CP=0
  1420. XC                        !CHAR PTR=0.
  1421. XC
  1422. X200    IF(PRSCON.GT.INLNT) GO TO 1000
  1423. XC                        !END OF INPUT?
  1424. X    J=INBUF(PRSCON)
  1425. XC                        !NO, GET CHARACTER,
  1426. X    PRSCON=PRSCON+1
  1427. XC                        !ADVANCE PTR.
  1428. X    IF(J.EQ.'.') GO TO 1000
  1429. XC                        !END OF COMMAND?
  1430. X    IF(J.EQ.',') GO TO 1000
  1431. XC                        !END OF COMMAND?
  1432. X    IF(J.EQ.' ') GO TO 6000
  1433. XC                        !SPACE?
  1434. X    DO 500 I=1,9,3
  1435. XC                        !SCH FOR CHAR.
  1436. X      IF(and((J.GE.DLIMIT(I)),(J.LE.DLIMIT(I+1))))
  1437. X&        GO TO 4000
  1438. X500    CONTINUE
  1439. XC
  1440. X    IF(VBFLAG) CALL RSPEAK(601)
  1441. XC                        !GREEK TO ME, FAIL.
  1442. X    RETURN
  1443. XC
  1444. XC END OF INPUT, SEE IF PARTIAL WORD AVAILABLE.
  1445. XC
  1446. X1000    IF(PRSCON.GT.INLNT) PRSCON=1
  1447. XC                        !FORCE PARSE RESTART.
  1448. X    IF(and((CP.EQ.0),(OP.EQ.1))) RETURN
  1449. X    IF(CP.EQ.0) OP=OP-2
  1450. XC                        !ANY LAST WORD?
  1451. X    LEX=.TRUE.
  1452. X#ifdef debug
  1453. X    IF(DFLAG) PRINT 10,CP,OP,PRSCON,(OUTBUF(I),I=1,OP+1)
  1454. X10    FORMAT(' LEX RESULTS- ',3I7/1X,10O7)
  1455. X#endif debug
  1456. X    RETURN
  1457. XC
  1458. XC LEGITIMATE CHARACTERS: LETTER, DIGIT, OR HYPHEN.
  1459. XC
  1460. X4000    J1=ichar(J)-ichar(DLIMIT(I+2))
  1461. X#ifdef debug
  1462. X    IF(DFLAG) PRINT 20,J,J1,CP
  1463. X20    FORMAT(' LEX- CHAR= ',3I7)
  1464. X#endif debug
  1465. X    IF(CP.GE.6) GO TO 200
  1466. XC                        !IGNORE IF TOO MANY CHAR.
  1467. X    K=OP+(CP/3)
  1468. XC                        !COMPUTE WORD INDEX.
  1469. X    GO TO (4100,4200,4300),(MOD(CP,3)+1)
  1470. XC                        !BRANCH ON CHAR.
  1471. X4100    J2=J1*780
  1472. XC                        !CHAR 1... *780
  1473. X    OUTBUF(K)=OUTBUF(K)+J2+J2
  1474. XC                        !*1560 (40 ADDED BELOW).
  1475. X4200    OUTBUF(K)=OUTBUF(K)+(J1*39)
  1476. XC                        !*39 (1 ADDED BELOW).
  1477. X4300    OUTBUF(K)=OUTBUF(K)+J1
  1478. XC                        !*1.
  1479. X    CP=CP+1
  1480. X    GO TO 200
  1481. XC                        !GET NEXT CHAR.
  1482. XC
  1483. XC SPACE
  1484. XC
  1485. X6000    IF(CP.EQ.0) GO TO 200
  1486. XC                        !ANY WORD YET?
  1487. X    GO TO 50
  1488. XC                        !YES, ADV OP.
  1489. XC
  1490. X    END
  1491. X#endif PDP
  1492. END_OF_np.F
  1493. if test 4769 -ne `wc -c <np.F`; then
  1494.     echo shar: \"np.F\" unpacked with wrong size!
  1495. fi
  1496. # end of overwriting check
  1497. fi
  1498. if test -f np2.F -a "${1}" != "-c" ; then 
  1499.   echo shar: Will not over-write existing file \"np2.F\"
  1500. else
  1501. echo shar: Extracting \"np2.F\" \(4830 characters\)
  1502. sed "s/^X//" >np2.F <<'END_OF_np2.F'
  1503. XC GETOBJ--    FIND OBJ DESCRIBED BY ADJ, NAME PAIR
  1504. XC
  1505. XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
  1506. XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  1507. XC WRITTEN BY R. M. SUPNIK
  1508. XC
  1509. XC DECLARATIONS
  1510. XC
  1511. XC THIS ROUTINE DETAILS ON BIT 3 OF PRSFLG
  1512. XC
  1513. X    INTEGER FUNCTION GETOBJ(OIDX,AIDX,SPCOBJ)
  1514. X    IMPLICIT INTEGER(A-Z)
  1515. X    LOGICAL THISIT,GHERE,LIT,CHOMP
  1516. X#include "parser.h"
  1517. X#include "gamestate.h"
  1518. XC
  1519. XC MISCELLANEOUS VARIABLES
  1520. XC
  1521. X    COMMON /STAR/ MBASE,STRBIT
  1522. X#include "debug.h"
  1523. X#include "objects.h"
  1524. X#include "oflags.h"
  1525. X#include "advers.h"
  1526. X#include "vocab.h"
  1527. XC GETOBJ, PAGE 2
  1528. XC
  1529. X#ifdef debug
  1530. X    DFLAG=and(PRSFLG, 8).NE.0
  1531. X#endif debug
  1532. X    CHOMP=.FALSE.
  1533. X    AV=AVEHIC(WINNER)
  1534. X    OBJ=0
  1535. XC                        !ASSUME DARK.
  1536. X    IF(.NOT.LIT(HERE)) GO TO 200
  1537. XC                        !LIT?
  1538. XC
  1539. X    OBJ=SCHLST(OIDX,AIDX,HERE,0,0,SPCOBJ)
  1540. XC                        !SEARCH ROOM.
  1541. X#ifdef debug
  1542. X    IF(DFLAG) PRINT 10,OBJ
  1543. X10    FORMAT(' SCHLST- ROOM SCH ',I6)
  1544. X#endif debug
  1545. X    IF(OBJ) 1000,200,100
  1546. XC                        !TEST RESULT.
  1547. X100    IF((AV.EQ.0).OR.(AV.EQ.OBJ).OR.
  1548. X&        (and(OFLAG2(OBJ),FINDBT).NE.0)) GO TO 200
  1549. X    IF(OCAN(OBJ).EQ.AV) GO TO 200
  1550. XC                        !TEST IF REACHABLE.
  1551. X    CHOMP=.TRUE.
  1552. XC                        !PROBABLY NOT.
  1553. XC
  1554. X200    IF(AV.EQ.0) GO TO 400
  1555. XC                        !IN VEHICLE?
  1556. X    NOBJ=SCHLST(OIDX,AIDX,0,AV,0,SPCOBJ)
  1557. XC                        !SEARCH VEHICLE.
  1558. X#ifdef debug
  1559. X    IF(DFLAG) PRINT 20,NOBJ
  1560. X20    FORMAT(' SCHLST- VEH SCH  ',I6)
  1561. X#endif debug
  1562. X    IF(NOBJ) 1100,400,300
  1563. XC                        !TEST RESULT.
  1564. X300    CHOMP=.FALSE.
  1565. XC                        !REACHABLE.
  1566. X    IF(OBJ.EQ.NOBJ) GO TO 400
  1567. XC                        !SAME AS BEFORE?
  1568. X    IF(OBJ.NE.0) NOBJ=-NOBJ
  1569. XC                        !AMB RESULT?
  1570. X    OBJ=NOBJ
  1571. XC
  1572. X400    NOBJ=SCHLST(OIDX,AIDX,0,0,WINNER,SPCOBJ)
  1573. XC                        !SEARCH ADVENTURER.
  1574. X#ifdef debug
  1575. X    IF(DFLAG) PRINT 30,NOBJ
  1576. X30    FORMAT(' SCHLST- ADV SCH  ',I6)
  1577. X#endif debug
  1578. X    IF(NOBJ) 1100,600,500
  1579. XC                        !TEST RESULT
  1580. X500    IF(OBJ.NE.0) NOBJ=-NOBJ
  1581. XC                        !AMB RESULT?
  1582. X1100    OBJ=NOBJ
  1583. XC                        !RETURN NEW OBJECT.
  1584. X600    IF(CHOMP) OBJ=-10000
  1585. XC                        !UNREACHABLE.
  1586. X1000    GETOBJ=OBJ
  1587. XC
  1588. X    IF(GETOBJ.NE.0) GO TO 1500
  1589. XC                        !GOT SOMETHING?
  1590. X    DO 1200 I=STRBIT+1,OLNT
  1591. XC                        !NO, SEARCH GLOBALS.
  1592. X      IF(.NOT.THISIT(OIDX,AIDX,I,SPCOBJ)) GO TO 1200
  1593. X      IF(.NOT.GHERE(I,HERE)) GO TO 1200
  1594. XC                        !CAN IT BE HERE?
  1595. X      IF(GETOBJ.NE.0) GETOBJ=-I
  1596. XC                        !AMB MATCH?
  1597. X      IF(GETOBJ.EQ.0) GETOBJ=I
  1598. X1200    CONTINUE
  1599. XC
  1600. X1500    CONTINUE
  1601. XC                        !END OF SEARCH.
  1602. X#ifdef debug
  1603. X    IF(DFLAG) PRINT 40,GETOBJ
  1604. X40    FORMAT(' SCHLST- RESULT   ',I6)
  1605. X#endif debug
  1606. X    RETURN
  1607. X    END
  1608. XC SCHLST--    SEARCH FOR OBJECT
  1609. XC
  1610. XC DECLARATIONS
  1611. XC
  1612. X    INTEGER FUNCTION SCHLST(OIDX,AIDX,RM,CN,AD,SPCOBJ)
  1613. X    IMPLICIT INTEGER(A-Z)
  1614. X    LOGICAL THISIT,QHERE,NOTRAN,NOVIS
  1615. XC
  1616. X    COMMON /STAR/ MBASE,STRBIT
  1617. X#include "objects.h"
  1618. X#include "oflags.h"
  1619. XC
  1620. XC FUNCTIONS AND DATA
  1621. XC
  1622. X    NOTRAN(O)=(and(OFLAG1(O),TRANBT).EQ.0).AND.
  1623. X&        (and(OFLAG2(O),OPENBT).EQ.0)
  1624. X    NOVIS(O)=(and(OFLAG1(O),VISIBT).EQ.0)
  1625. XC
  1626. X    SCHLST=0
  1627. XC                        !NO RESULT.
  1628. X    DO 1000 I=1,OLNT
  1629. XC                        !SEARCH OBJECTS.
  1630. X      IF(NOVIS(I).OR.
  1631. X&        (((RM.EQ.0).OR.(.NOT.QHERE(I,RM))).AND.
  1632. X&         ((CN.EQ.0).OR.(OCAN(I).NE.CN)).AND.
  1633. X&         ((AD.EQ.0).OR.(OADV(I).NE.AD)))) GO TO 1000
  1634. X      IF(.NOT.THISIT(OIDX,AIDX,I,SPCOBJ)) GO TO 200
  1635. X      IF(SCHLST.NE.0) GO TO 2000
  1636. XC                        !GOT ONE ALREADY?
  1637. X      SCHLST=I
  1638. XC                        !NO.
  1639. XC
  1640. XC IF OPEN OR TRANSPARENT, SEARCH THE OBJECT ITSELF.
  1641. XC
  1642. X200      IF(NOTRAN(I)) GO TO 1000
  1643. XC
  1644. XC SEARCH IS CONDUCTED IN REVERSE.  ALL OBJECTS ARE CHECKED TO
  1645. XC SEE IF THEY ARE AT SOME LEVEL OF CONTAINMENT INSIDE OBJECT 'I'.
  1646. XC IF THEY ARE AT LEVEL 1, OR IF ALL LINKS IN THE CONTAINMENT
  1647. XC CHAIN ARE OPEN, VISIBLE, AND HAVE SEARCHME SET, THEY CAN QUALIFY
  1648. XC AS A POTENTIAL MATCH.
  1649. XC
  1650. X      DO 500 J=1,OLNT
  1651. XC                        !SEARCH OBJECTS.
  1652. X        IF(NOVIS(J).OR. (.NOT.THISIT(OIDX,AIDX,J,SPCOBJ)))
  1653. X&        GO TO 500
  1654. X        X=OCAN(J)
  1655. XC                        !GET CONTAINER.
  1656. X300        IF(X.EQ.I) GO TO 400
  1657. XC                        !INSIDE TARGET?
  1658. X        IF(X.EQ.0) GO TO 500
  1659. XC                        !INSIDE ANYTHING?
  1660. X        IF(NOVIS(X).OR.NOTRAN(X).OR.
  1661. X&        (and(OFLAG2(X),SCHBT).EQ.0)) GO TO 500
  1662. X        X=OCAN(X)
  1663. XC                        !GO ANOTHER LEVEL.
  1664. X        GO TO 300
  1665. XC
  1666. X400        IF(SCHLST.NE.0) GO TO 2000
  1667. XC                        !ALREADY GOT ONE?
  1668. X        SCHLST=J
  1669. XC                        !NO.
  1670. X500      CONTINUE
  1671. XC
  1672. X1000    CONTINUE
  1673. X    RETURN
  1674. XC
  1675. X2000    SCHLST=-SCHLST
  1676. XC                        !AMB RETURN.
  1677. X    RETURN
  1678. XC
  1679. X    END
  1680. XC
  1681. XC THISIT--    VALIDATE OBJECT VS DESCRIPTION
  1682. XC
  1683. XC DECLARATIONS
  1684. XC
  1685. X    LOGICAL  FUNCTION  THISIT(OIDX,AIDX,OBJ,SPCOBJ)
  1686. X    IMPLICIT INTEGER(A-Z)
  1687. X    LOGICAL  NOTEST
  1688. X#include "vocab.h"
  1689. XC
  1690. XC FUNCTIONS AND DATA
  1691. XC
  1692. X    NOTEST(O)=(O.LE.0).OR.(O.GE.R50MIN)
  1693. XC
  1694. XC    THE FOLLOWING DATA STATEMENT USED RADIX-50 NOTATION (R50MIN/1RA/)
  1695. XC       IN RADIX-50 NOTATION, AN "A" IN THE FIRST POSITION IS
  1696. XC       ENCODED AS 1*40*40 = 1600.
  1697. XC
  1698. X    DATA R50MIN/1600/
  1699. XC
  1700. X    THISIT=.FALSE.
  1701. XC                        !ASSUME NO MATCH.
  1702. X    IF((SPCOBJ.NE.0).AND.(OBJ.EQ.SPCOBJ)) GO TO 500
  1703. XC
  1704. XC CHECK FOR OBJECT NAMES
  1705. XC
  1706. X    I=OIDX+1
  1707. X100    I=I+1
  1708. X    IF(NOTEST(OVOC(I))) RETURN
  1709. XC                        !IF DONE, LOSE.
  1710. X    IF(OVOC(I).NE.OBJ) GO TO 100
  1711. XC                        !IF FAIL, CONT.
  1712. XC
  1713. X    IF(AIDX.EQ.0) GO TO 500
  1714. XC                        !ANY ADJ?
  1715. X    I=AIDX+1
  1716. X200    I=I+1
  1717. X    IF(NOTEST(AVOC(I))) RETURN
  1718. XC                        !IF DONE, LOSE.
  1719. X    IF(AVOC(I).NE.OBJ) GO TO 200
  1720. XC                        !IF FAIL, CONT.
  1721. XC
  1722. X500    THISIT=.TRUE.
  1723. X    RETURN
  1724. X    END
  1725. END_OF_np2.F
  1726. if test 4830 -ne `wc -c <np2.F`; then
  1727.     echo shar: \"np2.F\" unpacked with wrong size!
  1728. fi
  1729. # end of overwriting check
  1730. fi
  1731. if test -f nrooms.F -a "${1}" != "-c" ; then 
  1732.   echo shar: Will not over-write existing file \"nrooms.F\"
  1733. else
  1734. echo shar: Extracting \"nrooms.F\" \(6745 characters\)
  1735. sed "s/^X//" >nrooms.F <<'END_OF_nrooms.F'
  1736. XC RAPPL2- SPECIAL PURPOSE ROOM ROUTINES, PART 2
  1737. XC
  1738. XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
  1739. XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  1740. XC WRITTEN BY R. M. SUPNIK
  1741. XC
  1742. XC DECLARATIONS
  1743. XC
  1744. X    LOGICAL FUNCTION RAPPL2(RI)
  1745. X    IMPLICIT INTEGER (A-Z)
  1746. X    LOGICAL QOPEN,QHERE
  1747. X#include "parser.h"
  1748. X#include "gamestate.h"
  1749. X#include "state.h"
  1750. X#include "io.h"
  1751. X#include "rooms.h"
  1752. X#include "rflag.h"
  1753. X#include "rindex.h"
  1754. X#include "objects.h"
  1755. X#include "oflags.h"
  1756. X#include "oindex.h"
  1757. X#include "xsrch.h"
  1758. X#include "clock.h"
  1759. X#include "advers.h"
  1760. X#include "verbs.h"
  1761. X#include "flags.h"
  1762. XC
  1763. XC FUNCTIONS AND DATA
  1764. XC
  1765. X    QOPEN(R)=and(OFLAG2(R),OPENBT).NE.0
  1766. X    DATA NEWRMS/38/
  1767. XC RAPPL2, PAGE 2
  1768. XC
  1769. X    RAPPL2=.TRUE.
  1770. X    GO TO (38000,39000,40000,41000,42000,43000,44000,
  1771. X&        45000,46000,47000,48000,49000,50000,
  1772. X&        51000,52000,53000,54000,55000,56000,
  1773. X&        57000,58000,59000,60000),
  1774. X&        (RI-NEWRMS+1)
  1775. X    CALL BUG(70,RI)
  1776. X    RETURN
  1777. XC
  1778. XC R38--    MIRROR D ROOM
  1779. XC
  1780. X38000    IF(PRSA.EQ.LOOKW) CALL LOOKTO(FDOOR,MRG,0,682,681)
  1781. X    RETURN
  1782. XC
  1783. XC R39--    MIRROR G ROOM
  1784. XC
  1785. X39000    IF(PRSA.EQ.WALKIW) CALL JIGSUP(685)
  1786. X    RETURN
  1787. XC
  1788. XC R40--    MIRROR C ROOM
  1789. XC
  1790. X40000    IF(PRSA.EQ.LOOKW) CALL LOOKTO(MRG,MRB,683,0,681)
  1791. X    RETURN
  1792. XC
  1793. XC R41--    MIRROR B ROOM
  1794. XC
  1795. X41000    IF(PRSA.EQ.LOOKW) CALL LOOKTO(MRC,MRA,0,0,681)
  1796. X    RETURN
  1797. XC
  1798. XC R42--    MIRROR A ROOM
  1799. XC
  1800. X42000    IF(PRSA.EQ.LOOKW) CALL LOOKTO(MRB,0,0,684,681)
  1801. X    RETURN
  1802. XC RAPPL2, PAGE 3
  1803. XC
  1804. XC R43--    MIRROR C EAST/WEST
  1805. XC
  1806. X43000    IF(PRSA.EQ.LOOKW) CALL EWTELL(HERE,683)
  1807. X    RETURN
  1808. XC
  1809. XC R44--    MIRROR B EAST/WEST
  1810. XC
  1811. X44000    IF(PRSA.EQ.LOOKW) CALL EWTELL(HERE,686)
  1812. X    RETURN
  1813. XC
  1814. XC R45--    MIRROR A EAST/WEST
  1815. XC
  1816. X45000    IF(PRSA.EQ.LOOKW) CALL EWTELL(HERE,687)
  1817. X    RETURN
  1818. XC
  1819. XC R46--    INSIDE MIRROR
  1820. XC
  1821. X46000    IF(PRSA.NE.LOOKW) RETURN
  1822. XC                        !LOOK?
  1823. X    CALL RSPEAK(688)
  1824. XC                        !DESCRIBE
  1825. XC
  1826. XC NOW DESCRIBE POLE STATE.
  1827. XC
  1828. XC CASES 1,2--    MDIR=270 & MLOC=MRB, POLE IS UP OR IN HOLE
  1829. XC CASES 3,4--    MDIR=0 V MDIR=180, POLE IS UP OR IN CHANNEL
  1830. XC CASE 5--    POLE IS UP
  1831. XC
  1832. X    I=689
  1833. XC                        !ASSUME CASE 5.
  1834. X    IF((MDIR.EQ.270).AND.(MLOC.EQ.MRB))
  1835. X&        I=690+MIN0(POLEUF,1)
  1836. X    IF(MOD(MDIR,180).EQ.0)
  1837. X&        I=692+MIN0(POLEUF,1)
  1838. X    CALL RSPEAK(I)
  1839. XC                        !DESCRIBE POLE.
  1840. X    CALL RSPSUB(694,695+(MDIR/45))
  1841. XC                        !DESCRIBE ARROW.
  1842. X    RETURN
  1843. XC RAPPL2, PAGE 4
  1844. XC
  1845. XC R47--    MIRROR EYE ROOM
  1846. XC
  1847. X47000    IF(PRSA.NE.LOOKW) RETURN
  1848. XC                        !LOOK?
  1849. X    I=704
  1850. XC                        !ASSUME BEAM STOP.
  1851. X    DO 47100 J=1,OLNT
  1852. X      IF(QHERE(J,HERE).AND.(J.NE.RBEAM)) GO TO 47200
  1853. X47100    CONTINUE
  1854. X    I=703
  1855. X47200    CALL RSPSUB(I,ODESC2(J))
  1856. XC                        !DESCRIBE BEAM.
  1857. X    CALL LOOKTO(MRA,0,0,0,0)
  1858. XC                        !LOOK NORTH.
  1859. X    RETURN
  1860. XC
  1861. XC R48--    INSIDE CRYPT
  1862. XC
  1863. X48000    IF(PRSA.NE.LOOKW) RETURN
  1864. XC                        !LOOK?
  1865. X    I=46
  1866. XC                        !CRYPT IS OPEN/CLOSED.
  1867. X    IF(QOPEN(TOMB)) I=12
  1868. X    CALL RSPSUB(705,I)
  1869. X    RETURN
  1870. XC
  1871. XC R49--    SOUTH CORRIDOR
  1872. XC
  1873. X49000    IF(PRSA.NE.LOOKW) RETURN
  1874. XC                        !LOOK?
  1875. X    CALL RSPEAK(706)
  1876. XC                        !DESCRIBE.
  1877. X    I=46
  1878. XC                        !ODOOR IS OPEN/CLOSED.
  1879. X    IF(QOPEN(ODOOR)) I=12
  1880. X    IF(LCELL.EQ.4) CALL RSPSUB(707,I)
  1881. XC                        !DESCRIBE ODOOR IF THERE.
  1882. X    RETURN
  1883. XC
  1884. XC R50--    BEHIND DOOR
  1885. XC
  1886. X50000    IF(PRSA.NE.WALKIW) GO TO 50100
  1887. XC                        !WALK IN?
  1888. X    CFLAG(CEVFOL)=.TRUE.
  1889. XC                        !MASTER FOLLOWS.
  1890. X    CTICK(CEVFOL)=-1
  1891. X    RETURN
  1892. XC
  1893. X50100    IF(PRSA.NE.LOOKW) RETURN
  1894. XC                        !LOOK?
  1895. X    I=46
  1896. XC                        !QDOOR IS OPEN/CLOSED.
  1897. X    IF(QOPEN(QDOOR)) I=12
  1898. X    CALL RSPSUB(708,I)
  1899. X    RETURN
  1900. XC RAPPL2, PAGE 5
  1901. XC
  1902. XC R51--    FRONT DOOR
  1903. XC
  1904. X51000    IF(PRSA.EQ.WALKIW) CTICK(CEVFOL)=0
  1905. XC                        !IF EXITS, KILL FOLLOW.
  1906. X    IF(PRSA.NE.LOOKW) RETURN
  1907. XC                        !LOOK?
  1908. X    CALL LOOKTO(0,MRD,709,0,0)
  1909. XC                        !DESCRIBE SOUTH.
  1910. X    I=46
  1911. XC                        !PANEL IS OPEN/CLOSED.
  1912. X    IF(INQSTF) I=12
  1913. XC                        !OPEN IF INQ STARTED.
  1914. X    J=46
  1915. XC                        !QDOOR IS OPEN/CLOSED.
  1916. X    IF(QOPEN(QDOOR)) J=12
  1917. X    CALL RSPSB2(710,I,J)
  1918. X    RETURN
  1919. XC
  1920. XC R52--    NORTH CORRIDOR
  1921. XC
  1922. X52000    IF(PRSA.NE.LOOKW) RETURN
  1923. XC                        !LOOK?
  1924. X    I=46
  1925. X    IF(QOPEN(CDOOR)) I=12
  1926. XC                        !CDOOR IS OPEN/CLOSED.
  1927. X    CALL RSPSUB(711,I)
  1928. X    RETURN
  1929. XC
  1930. XC R53--    PARAPET
  1931. XC
  1932. X53000    IF(PRSA.EQ.LOOKW) CALL RSPSUB(712,712+PNUMB)
  1933. X    RETURN
  1934. XC
  1935. XC R54--    CELL
  1936. XC
  1937. X54000    IF(PRSA.NE.LOOKW) RETURN
  1938. XC                        !LOOK?
  1939. X    I=721
  1940. XC                        !CDOOR IS OPEN/CLOSED.
  1941. X    IF(QOPEN(CDOOR)) I=722
  1942. X    CALL RSPEAK(I)
  1943. X    I=46
  1944. XC                        !ODOOR IS OPEN/CLOSED.
  1945. X    IF(QOPEN(ODOOR)) I=12
  1946. X    IF(LCELL.EQ.4) CALL RSPSUB(723,I)
  1947. XC                        !DESCRIBE.
  1948. X    RETURN
  1949. XC
  1950. XC R55--    PRISON CELL
  1951. XC
  1952. X55000    IF(PRSA.EQ.LOOKW) CALL RSPEAK(724)
  1953. XC                        !LOOK?
  1954. X    RETURN
  1955. XC
  1956. XC R56--    NIRVANA CELL
  1957. XC
  1958. X56000    IF(PRSA.NE.LOOKW) RETURN
  1959. XC                        !LOOK?
  1960. X    I=46
  1961. XC                        !ODOOR IS OPEN/CLOSED.
  1962. X    IF(QOPEN(ODOOR)) I=12
  1963. X    CALL RSPSUB(725,I)
  1964. X    RETURN
  1965. XC RAPPL2, PAGE 6
  1966. XC
  1967. XC R57--    NIRVANA AND END OF GAME
  1968. XC
  1969. X57000    IF(PRSA.NE.WALKIW) RETURN
  1970. XC                        !WALKIN?
  1971. X    CALL RSPEAK(726)
  1972. X    CALL SCORE(.FALSE.)
  1973. XC moved to exit routine    CLOSE(DBCH)
  1974. X    CALL EXIT
  1975. XC
  1976. XC R58--    TOMB ROOM
  1977. XC
  1978. X58000    IF(PRSA.NE.LOOKW) RETURN
  1979. XC                        !LOOK?
  1980. X    I=46
  1981. XC                        !TOMB IS OPEN/CLOSED.
  1982. X    IF(QOPEN(TOMB)) I=12
  1983. X    CALL RSPSUB(792,I)
  1984. X    RETURN
  1985. XC
  1986. XC R59--    PUZZLE SIDE ROOM
  1987. XC
  1988. X59000    IF(PRSA.NE.LOOKW) RETURN
  1989. XC                        !LOOK?
  1990. X    I=861
  1991. XC                        !ASSUME DOOR CLOSED.
  1992. X    IF(CPOUTF) I=862
  1993. XC                        !OPEN?
  1994. X    CALL RSPEAK(I)
  1995. XC                        !DESCRIBE.
  1996. X    RETURN
  1997. XC
  1998. XC R60--    PUZZLE ROOM
  1999. XC
  2000. X60000    IF(PRSA.NE.LOOKW) RETURN
  2001. XC                        !LOOK?
  2002. X    IF(CPUSHF) GO TO 60100
  2003. XC                        !STARTED PUZZLE?
  2004. X    CALL RSPEAK(868)
  2005. XC                        !NO, DESCRIBE.
  2006. X    IF(and(OFLAG2(WARNI),TCHBT).NE.0) CALL RSPEAK(869)
  2007. X    RETURN
  2008. XC
  2009. X60100    CALL CPINFO(880,CPHERE)
  2010. XC                        !DESCRIBE ROOM.
  2011. X    RETURN
  2012. XC
  2013. X    END
  2014. XC LOOKTO--    DESCRIBE VIEW IN MIRROR HALLWAY
  2015. XC
  2016. XC DECLARATIONS
  2017. XC
  2018. X    SUBROUTINE LOOKTO(NRM,SRM,NT,ST,HT)
  2019. X    IMPLICIT INTEGER(A-Z)
  2020. X#include "gamestate.h"
  2021. X#include "flags.h"
  2022. XC LOOKTO, PAGE 2
  2023. XC
  2024. X    CALL RSPEAK(HT)
  2025. XC                        !DESCRIBE HALL.
  2026. X    CALL RSPEAK(NT)
  2027. XC                        !DESCRIBE NORTH VIEW.
  2028. X    CALL RSPEAK(ST)
  2029. XC                        !DESCRIBE SOUTH VIEW.
  2030. X    DIR=0
  2031. XC                        !ASSUME NO DIRECTION.
  2032. X    IF(IABS(MLOC-HERE).NE.1) GO TO 200
  2033. XC                        !MIRROR TO N OR S?
  2034. X    IF(MLOC.EQ.NRM) DIR=695
  2035. X    IF(MLOC.EQ.SRM) DIR=699
  2036. XC                        !DIR=N/S.
  2037. X    IF(MOD(MDIR,180).NE.0) GO TO 100
  2038. XC                        !MIRROR N-S?
  2039. X    CALL RSPSUB(847,DIR)
  2040. XC                        !YES, HE SEES PANEL
  2041. X    CALL RSPSB2(848,DIR,DIR)
  2042. XC                        !AND NARROW ROOMS.
  2043. X    GO TO 200
  2044. XC
  2045. X100    M1=MRHERE(HERE)
  2046. XC                        !WHICH MIRROR?
  2047. X    MRBF=0
  2048. XC                        !ASSUME INTACT.
  2049. X    IF(((M1.EQ.1).AND..NOT.MR1F).OR.
  2050. X&      ((M1.EQ.2).AND..NOT.MR2F)) MRBF=1
  2051. X    CALL RSPSUB(849+MRBF,DIR)
  2052. XC                        !DESCRIBE.
  2053. X    IF((M1.EQ.1).AND.MROPNF) CALL RSPEAK(823+MRBF)
  2054. X    IF(MRBF.NE.0) CALL RSPEAK(851)
  2055. XC
  2056. X200    I=0
  2057. XC                        !ASSUME NO MORE TO DO.
  2058. X    IF((NT.EQ.0).AND.((DIR.EQ.0).OR.(DIR.EQ.699))) I=852
  2059. X    IF((ST.EQ.0).AND.((DIR.EQ.0).OR.(DIR.EQ.695))) I=853
  2060. X    IF((NT+ST+DIR).EQ.0) I=854
  2061. X    IF(HT.NE.0) CALL RSPEAK(I)
  2062. XC                        !DESCRIBE HALLS.
  2063. X    RETURN
  2064. XC
  2065. X    END
  2066. XC EWTELL--    DESCRIBE E/W NARROW ROOMS
  2067. XC
  2068. XC DECLARATIONS
  2069. XC
  2070. X    SUBROUTINE EWTELL(RM,ST)
  2071. X    IMPLICIT INTEGER(A-Z)
  2072. X    LOGICAL M1
  2073. XC
  2074. XC ROOMS
  2075. X#include "rindex.h"
  2076. X#include "flags.h"
  2077. XC EWTELL, PAGE 2
  2078. XC
  2079. XC NOTE THAT WE ARE EAST OR WEST OF MIRROR, AND
  2080. XC MIRROR MUST BE N-S.
  2081. XC
  2082. X    M1=(MDIR+(MOD(RM-MRAE,2)*180)).EQ.180
  2083. X    I=819+MOD(RM-MRAE,2)
  2084. XC                        !GET BASIC E/W STRING.
  2085. X    IF((M1.AND..NOT.MR1F).OR.(.NOT.M1.AND..NOT.MR2F))
  2086. X&        I=I+2
  2087. X    CALL RSPEAK(I)
  2088. X    IF(M1.AND.MROPNF) CALL RSPEAK(823+((I-819)/2))
  2089. X    CALL RSPEAK(825)
  2090. X    CALL RSPEAK(ST)
  2091. X    RETURN
  2092. XC
  2093. X    END
  2094. END_OF_nrooms.F
  2095. if test 6745 -ne `wc -c <nrooms.F`; then
  2096.     echo shar: \"nrooms.F\" unpacked with wrong size!
  2097. fi
  2098. # end of overwriting check
  2099. fi
  2100. if test -f oflags.h -a "${1}" != "-c" ; then 
  2101.   echo shar: Will not over-write existing file \"oflags.h\"
  2102. else
  2103. echo shar: Extracting \"oflags.h\" \(269 characters\)
  2104. sed "s/^X//" >oflags.h <<'END_OF_oflags.h'
  2105. XC
  2106. X    COMMON /OFLAGS/ VISIBT,READBT,TAKEBT,DOORBT,TRANBT,FOODBT,
  2107. X&        NDSCBT,DRNKBT,CONTBT,LITEBT,VICTBT,BURNBT,FLAMBT,
  2108. X&        TOOLBT,TURNBT,ONBT
  2109. X    COMMON /OFLAGS/ FINDBT,SLEPBT,SCRDBT,TIEBT,CLMBBT,ACTRBT,
  2110. X&        WEAPBT,FITEBT,VILLBT,STAGBT,TRYBT,NOCHBT,OPENBT,
  2111. X&        TCHBT,VEHBT,SCHBT
  2112. END_OF_oflags.h
  2113. if test 269 -ne `wc -c <oflags.h`; then
  2114.     echo shar: \"oflags.h\" unpacked with wrong size!
  2115. fi
  2116. # end of overwriting check
  2117. fi
  2118. if test -f speak.F -a "${1}" != "-c" ; then 
  2119.   echo shar: Will not over-write existing file \"speak.F\"
  2120. else
  2121. echo shar: Extracting \"speak.F\" \(3842 characters\)
  2122. sed "s/^X//" >speak.F <<'END_OF_speak.F'
  2123. X#include "files.h"
  2124. X
  2125. X#ifndef RTEXTFILE
  2126. X#define RTEXTFILE '/usr/games/lib/dunlib/rtext.dat'
  2127. X#endif
  2128. X
  2129. X#ifndef TEXTFILE
  2130. X#define TEXTFILE '/usr/games/lib/dunlib/dtext.dat'
  2131. X#endif
  2132. X
  2133. XC
  2134. XC    manual speak routine
  2135. XC    gets dungeon messages and prints them
  2136. XC    (only used for pdp version)
  2137. XC
  2138. X    program speak
  2139. X    IMPLICIT      INTEGER(A-Z)
  2140. XC
  2141. X    COMMON /CHAN/ INPCH,OUTCH,DBCH
  2142. X#include "mindex.h"
  2143. XC    
  2144. XC    load the lookup table
  2145. XC
  2146. X    OPEN(UNIT=9,file=RTEXTFILE,
  2147. X&        status='OLD',IOSTAT=IO,
  2148. X&        FORM='formatted',ACCESS='SEQUENTIAL',err=50)
  2149. XC
  2150. X    call load
  2151. XC
  2152. XC    open the message file
  2153. XC
  2154. X    DBCH=2
  2155. XC
  2156. X    OPEN(UNIT=DBCH,file=TEXTFILE,
  2157. X&        status='OLD',IOSTAT=IO,
  2158. X&        FORM='UNFORMATTED',ACCESS='DIRECT',recl=76,err=60)
  2159. XC
  2160. X    print 20
  2161. X20    format('Sigh... '/)
  2162. XC
  2163. XC    get numbers and call speaking program
  2164. XC
  2165. X10    continue 
  2166. XC
  2167. X    call inprd(mesage,i,j)
  2168. X    call RSPSB2(mesage,i,j)
  2169. X    goto 10
  2170. XC
  2171. XC INITIALIZATION ERROR
  2172. XC
  2173. X50    print 960
  2174. X    print 980
  2175. X    goto 99
  2176. X60    print 970
  2177. X    print 980
  2178. X    goto 99
  2179. X960    FORMAT(' I can''t open ',RTEXTFILE,'.')
  2180. X970    FORMAT(' I can''t open ',TEXTFILE,'.')
  2181. X980    FORMAT(' Suddenly a sinister, wraithlike figure appears before '
  2182. X&    'you,'/' seeming to float in the air.  In a low, sorrowful voice'
  2183. X&    ' he says,'/' "Alas, the very nature of the world has changed, '
  2184. X&    'and the dungeon'/' cannot be found.  All must now pass away."'
  2185. X&    '  Raising his oaken staff'/' in farewell, he fades into the '
  2186. X&    'spreading darkness.  In his place'/' appears a tastefully '
  2187. X&    'lettered sign reading:'//23X,'INITIALIZATION FAILURE'//
  2188. X&    ' The darkness becomes all encompassing, and your vision fails.')
  2189. X99    stop
  2190. X    end
  2191. XC
  2192. XC RSPSB2-- OUTPUT RANDOM MESSAGE WITH SUBSTITUTABLE ARGUMENTS
  2193. XC
  2194. XC CALLED BY--
  2195. XC
  2196. XC    CALL RSPSB2(MSGNUM,S1,S2)
  2197. XC
  2198. X    SUBROUTINE    RSPSB2(A,B,C)
  2199. X    IMPLICIT      INTEGER(A-Z)
  2200. X    CHARACTER*74  B1,B2,B3
  2201. X    INTEGER*2     OLDREC,NEWREC,JREC
  2202. XC
  2203. XC DECLARATIONS
  2204. XC
  2205. XC
  2206. X    COMMON /RMSG/ MLNT,RTEXT(1050)
  2207. X    COMMON /CHAN/ INPCH,OUTCH,DBCH
  2208. XC
  2209. XC CONVERT ALL ARGUMENTS FROM DICTIONARY NUMBERS (IF POSITIVE)
  2210. XC TO ABSOLUTE RECORD NUMBERS.
  2211. XC
  2212. X    X=A                    
  2213. X    Y=B
  2214. X    Z=C
  2215. X    IF(X.GT.0) X=RTEXT(X)            
  2216. X    IF(Y.GT.0) Y=RTEXT(Y)
  2217. X    IF(Z.GT.0) Z=RTEXT(Z)
  2218. X    X=IABS(X)                
  2219. X    Y=IABS(Y)
  2220. X    Z=IABS(Z)
  2221. X    IF(X.EQ.0) RETURN            
  2222. XC
  2223. X    READ(UNIT=DBCH,REC=X) OLDREC,B1
  2224. XC
  2225. X100    DO 150 I=1,74
  2226. X      X1=and(X,31)+I
  2227. X      B1(I:I)=char(xor(ichar(B1(I:I)),X1))
  2228. X150    CONTINUE
  2229. XC
  2230. X200    IF(Y.EQ.0) GO TO 400            
  2231. X    DO 300 I=1,74                
  2232. X      IF(B1(I:I).EQ.'#') GO TO 1000
  2233. X300    CONTINUE
  2234. XC
  2235. X400    DO 500 I=74,1,-1            
  2236. X      IF(B1(I:I).NE.' ') GO TO 600
  2237. X500    CONTINUE
  2238. XC
  2239. XC  600    WRITE(OUTCH,650) (B1(J:J),J=1,I)        
  2240. X600    PRINT 650, (B1(J:J),J=1,I)        
  2241. X650    FORMAT(1X,74A1)
  2242. X    X=X+1                    
  2243. X    READ(UNIT=DBCH,REC=X) NEWREC,B1
  2244. X    IF(OLDREC.EQ.NEWREC) GO TO 100        
  2245. X    RETURN                    
  2246. XC
  2247. XC SUBSTITUTION WITH SUBSTITUTABLE AVAILABLE.
  2248. XC I IS INDEX OF # IN B1.
  2249. XC Y IS NUMBER OF RECORD TO SUBSTITUTE.
  2250. XC
  2251. XC PROCEDURE:
  2252. XC   1) COPY REST OF B1 TO B2
  2253. XC   2) READ SUBSTITUTABLE OVER B1
  2254. XC   3) RESTORE TAIL OF ORIGINAL B1
  2255. XC
  2256. XC THE IMPLICIT ASSUMPTION HERE IS THAT THE SUBSTITUTABLE STRING
  2257. XC IS VERY SHORT (i.e. MUCH LESS THAN ONE RECORD).
  2258. XC
  2259. X1000    K2=1                    
  2260. X    DO 1100 K1=I+1,74            
  2261. X      B2(K2:K2)=B1(K1:K1)
  2262. X      K2=K2+1
  2263. X1100    CONTINUE
  2264. XC
  2265. XC   READ SUBSTITUTE STRING INTO B3, AND DECRYPT IT:
  2266. XC
  2267. X    READ(UNIT=DBCH,REC=Y) JREC,B3
  2268. X    DO 1150 K1=1,74
  2269. X      X1=and(Y,31)+K1
  2270. X      B3(K1:K1)=char(xor(ICHAR(B3(K1:K1)),X1))
  2271. X1150    CONTINUE
  2272. XC
  2273. XC   FILL REMAINDER OF B1 WITH CHARACTERS FROM B3:
  2274. XC
  2275. X    K2=1
  2276. X    DO 1180 K1=I,74
  2277. X      B1(K1:K1)=B3(K2:K2)
  2278. X      K2=K2+1
  2279. X1180    CONTINUE
  2280. XC
  2281. XC   FIND END OF SUBSTITUTE STRING IN B1:
  2282. XC
  2283. X    DO 1200 J=74,1,-1            
  2284. X      IF(B1(J:J).NE.' ') GO TO 1300
  2285. X1200    CONTINUE
  2286. XC
  2287. XC   PUT TAIL END OF B1 (NOW IN B2) BACK INTO B1 AFTER SUBSTITUTE STRING:
  2288. XC
  2289. X1300    K1=1                    
  2290. X    DO 1400 K2=J+1,74            
  2291. X      B1(K2:K2)=B2(K1:K1)
  2292. X      K1=K1+1
  2293. X1400    CONTINUE
  2294. XC
  2295. X    Y=Z                    
  2296. X    Z=0                    
  2297. X    GO TO 200                
  2298. XC
  2299. X    END
  2300. X    SUBROUTINE LOAD    
  2301. X    IMPLICIT INTEGER (A-Z)
  2302. XC
  2303. XC    load rtext data 
  2304. XC
  2305. XC
  2306. XC MESSAGE INDEX
  2307. XC
  2308. X    COMMON /RMSG/ MLNT,RTEXT(1050)
  2309. XC
  2310. XC
  2311. X    rewind 9
  2312. XC
  2313. XC     load the data
  2314. XC
  2315. XC
  2316. X    READ(9,130) RTEXT
  2317. X130    FORMAT(I8)
  2318. X    close(9)
  2319. XC
  2320. XC
  2321. X    return
  2322. X    END
  2323. END_OF_speak.F
  2324. if test 3842 -ne `wc -c <speak.F`; then
  2325.     echo shar: \"speak.F\" unpacked with wrong size!
  2326. fi
  2327. # end of overwriting check
  2328. fi
  2329. echo shar: End of archive 6 \(of 14\).
  2330. cp /dev/null ark6isdone
  2331. MISSING=""
  2332. for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 ; do
  2333.     if test ! -f ark${I}isdone ; then
  2334.     MISSING="${MISSING} ${I}"
  2335.     fi
  2336. done
  2337. if test "${MISSING}" = "" ; then
  2338.     echo You have unpacked all 14 archives.
  2339.     rm -f ark[1-9]isdone ark1[1-9]isdone
  2340. else
  2341.     echo You still need to unpack the following archives:
  2342.     echo "        " ${MISSING}
  2343. fi
  2344. ##  End of shell archive.
  2345. exit 0
  2346.